Your Choice 3/Your Choice Software Collection 3.iso/prgmming/qb_tips/qbtips_n.doc

Text File | 1993-07-26 | 160KB | 4,569 lines

Name:             QBTips_N.Doc                         Date:  8/93

Also See:         QBTips_A through QBTips_M


Purpose:          To provide insights and source code to help BASIC
                  programmers -- beginner through advanced.

                  Load this into your word processor or editor.  Then
                  scan it for tidbits you think will be useful.  Just
                  "cut & paste" sections you like to separate files,
                  then run the code.


Source:           Below you'll find messages captured from the FidoNet
                  Quik_Bas echo.  We captured CODE and significant tips,
                  and eliminated chatter.


Format:           Varies, depending on the author, their programming
                  style, and the question or topic.

                  A form-feed (Chr$(12)) appears after most messages.
                  This allows you to print this, and have each message
                  (ie., each topic) start on a new page.


Recommendation:   None!

                  Some of what you'll see below is brilliant.  Some
                  demonstrates very poor programming techniques.  But
                  all of it can prove useful if you have a need.

                  NOTE 1:

                  We have NOT tried all the code you see here, and some
                  of it may not run as-is.  You may have to do a little
                  editing to coax it.  One reason that code may not run
                  is that messages sometimes get truncated or mangled in
                  transmission.  Another reason is that authors make
                  mistakes (or typos).  Again, we haven't tried running
                  everything; but when you do, you'll probably quickly
                  spot places that need editing.

                  NOTE 2:

                  There may be near-duplicate messages.  The original
                  author may have refined the code, or may have found
                  errors in the original.  If you see something that
                  looks interesting, before you rely on the code, scan
                  for the topic or author to see if a new set of code is
                  below you -- more recent messages appear below. And
                  note that the next message may be in a later package.

                  NOTE 3:

                  BEFORE running any code segment, scan through it and
                  LOOK FOR code fragments which could be DISASTROUS!

                  *** We often run un-tested code fragments from a  ***
                  *** RAM or floppy disk.  And BEFORE running it we ***
                  *** scan for "c:" or "d:" (or other hard drive)   ***
                  *** letters.  And we also scan for .. (see below) ***


                  For example, scan for "OUT " -- and if you find any
                  verify that the code is OUTting the correct values
                  to the correct ports.  Typos, transmission errors
                  or programmer mistakes could send the wrong values
                  to the wrong ports.  At best, nothing will happen.
                  At worst, you might fry your monitor -- or worse.

                  Also look for INTERRUPT (or INTERRUPTx).  These functions
                  are v-e-r-y useful for invoking low-level DOS or BIOS
                  functions.  But that low-level access also comes with
                  some risks!  Programmer or transmission errors, open
                  drive doors, etc., can, at best, cause your PC to hang.
                  At worst, you could corrupt the FAT of your hard disk.


=========================================================================




' From:  VICTOR YIU                Sent: 07-12-93 13:32
'   To:  ALL                       Rcvd: -NO-
'   Re:  BROWSER 1.0 NOTES
'
'Hi, All!
'
'Following two messages, I will present you Browser, a really quick hex
'file viewer, just like Calvin's Hexview, except using my SuperHex asm.
'procedure.  Capture the basic file (BROWSER.BAS), the PostIt! file to
'make the OBJ file, and then the two messages of the asm I wrote.
'
'QB users must change all occurences of SSEG to VARSEG.
'
'Enjoy!  And I want to know if it feels SNAPPY on your machine!

' ==================== Browser 1.0 =======================
' by Victor Yiu, July 1993.  Released into Public Domain.
'
'              *** LOAD WITH /AH SWITCH ***
' This program is a binary file viewer, in hex and ascii,
' made to look like Calvin French's HEXVIEW, PCTools' View,
' Norton's DiskEdit, and numerous others.  It uses my public-
' domain SuperHex library, written in optimized assembly -- so
' it is FAST!
'                      (to make EXE:)
'       BC BROWSER /O;
'       LINK /FARC /PACKC:64000 BROWSER+C:\QB\NOCOM,,,C:\QB\BCOM45+SUPERHEX;
'            ^ (include "/EX" if you won't use LZEXE or PKLITE)
'
' Compared to Clavin's HEXVIEW:
'   o  Mine can open files up to 128k
'   o  Mine is 5 million times faster (faster than PCTools or Norton)
'   o  Has a built-in text filter
'   o  Acceptable on an 4.77 MHz XT!
'   o  Compiles to only 25K with LZEXE or PKLITE!
'
' Next version will include search and editing features.
'
' Speed comparison (on a 10MHz XT)*:
'       Calvin French's HEXVIEW:   .55 K/sec
'             PCTool's 4.x Edit:     3 K/sec
'         Victor's SuperHEX (!):    20 K/sec   --->  WOW!
'
'  * I didn't do timing on my 486 because it was too darn fast!
'
' By the way -- try loading a file from the floppy -- it's fun!
' ============================================================

DEFINT A-Z      ' $DYNAMIC

CONST Block = 8192, PageSize = 16 * 21, LastDataLine = 23
CONST DataFG = 7, DataBG = 1, Attrib = DataFG + DataBG * 16
CONST False = 0, True = NOT False

DECLARE SUB AdjustLastBytes (Row%)
DECLARE SUB CheckPointer (Num&)
DECLARE SUB DrawInterface ()
DECLARE SUB DrawScreen ()
DECLARE SUB LoadFile (LOFile&)
DECLARE SUB PrintHex (Num&)
DECLARE SUB ShowHex (Posit&)
DECLARE FUNCTION GetAdapterSeg% ()
DECLARE FUNCTION Signed% (Num&)

DECLARE SUB Scroll (BYVAL GoUp, BYVAL Attrib)
DECLARE SUB MemCopy (BYVAL SegFrom, BYVAL OffFrom, BYVAL SegTo,_
 BYVAL OffTo, BYVAL Leng)
DECLARE SUB SuperHex (BYVAL VidSeg, BYVAL Row, BYVAL OffsetHex,_
 BYVAL OffsetASCii, BYVAL segment, BYVAL Offset, BYVAL_
 BackColor, BYVAL FilterOn)
' VidSeg     = Video segment of adapter (B800 for color, B000 for mono)
' Row        = Row to display data (1-25)
' OffsetHex  = Column to display the hex digits (1-)
' OffsetASCii= Column to display the characters themselves (1-)
' Segment    = Segment of source data
' Offset     = Offset of source data
' BackColor  = Background color in a packed byte:
'                (BackGround * 16) + ForeGround

IF LEN(COMMAND$) = 0 THEN
    PRINT "Syntax:"
    PRINT "   BROWSER <filename>"
    END
END IF

DIM SHARED VidSegment, Pointer&, LastBox, LOFile&, FilterOn

OPEN COMMAND$ FOR BINARY AS #1
LOFile& = LOF(1)
IF (LOFile& + 3000 > FRE(-1)) OR (LOFile& > 131000) THEN PRINT "File too big.": END
IF LOFile& = 0 THEN CLOSE : PRINT COMMAND$; " does not exist.":KILL COMMAND$: END

DIM SHARED Array&(LOFile& \ 4& + 4)
Pointer& = 0: LastBox = 4: Null$ = CHR$(0)

CLS
VidSegment = GetAdapterSeg
DrawInterface
LOCATE 12, 33: COLOR 31, 3
PRINT " Loading file ... "; : COLOR 7

LoadFile LOFile&

IF LOFile& - 16 < PageSize THEN
    LOCATE 12, 33: COLOR , 1
    PRINT SPACE$(40);
END IF

DrawScreen
DO
    DO: I$ = INKEY$
    LOOP UNTIL LEN(I$)
    IF LEN(I$) = 1 THEN I$ = UCASE$(I$)

    SELECT CASE I$
        CASE Null$ + "Q", CHR$(13), " "   ' PageDown
            Pointer& = Pointer& + PageSize
            CheckPointer Pointer&
        CASE Null$ + "I"        ' PageUp
            Pointer& = Pointer& - PageSize
            CheckPointer Pointer&
        CASE Null$ + "P"        ' Down
            IF Pointer& + PageSize < LOFile& THEN
                Scroll 0, LastDataLine
                Pointer& = Pointer& + 16
                ShowHex Pointer&

                Temp& = Pointer& + PageSize - 16
                LOCATE LastDataLine, 3: COLOR 14
                PrintHex Temp&

                SuperHex VidSegment, LastDataLine, 10, 62,_
 Signed(sseg(Array&(0)) + Temp& \ 16), VARPTR(Array&(0)),_
 Attrib, FilterOn
                IF LOFile& - Temp& < 15 THEN AdjustLastBytes_
 LastDataLine
            END IF
        CASE Null$ + "H"        ' Up
            IF Pointer& >= 16 THEN
                Scroll -1, LastDataLine
                Pointer& = Pointer& - 16
                ShowHex Pointer&

                LOCATE 3, 3: COLOR 14
                PrintHex Pointer&
                SuperHex VidSegment, 3, 10, 62,_
 Signed(sseg(Array&(0)) + Pointer& \ 16), VARPTR(Array&(0)),_
 Attrib, FilterOn
            END IF
        CASE Null$ + "G"        ' Home
            Pointer& = 0
            DrawScreen
        CASE Null$ + "O"        ' End
            Pointer& = LOFile&
            CheckPointer Pointer&
        CASE "F"                ' toggle filter
            FilterOn = NOT FilterOn
            DrawScreen

            LOCATE 25, 58: COLOR 4, 3
            IF FilterOn THEN PRINT CHR$(251);  ELSE PRINT " ";
        CASE ELSE
    END SELECT
LOOP UNTIL I$ = CHR$(27)

COLOR 7, 0: CLS
PRINT "Thanks for trying Browser 1.0!"
PRINT
END

REM $STATIC
SUB AdjustLastBytes (Row)

    Remov = 16 - (LOFile& AND 15)
    LOCATE Row, 58 - Remov * 3
    PRINT SPACE$(Remov * 3 + 1);
    LOCATE , 78 - Remov
    PRINT SPACE$(Remov);

END SUB

SUB CheckPointer (Num&)

IF Num& + PageSize - 15 > LOFile& THEN
    Num& = LOFile& + 15 - PageSize
END IF

IF Num& < 0 THEN Num& = 0
DrawScreen

END SUB

SUB DrawInterface

COLOR 14, 12
PRINT " Browser 1.0  ■  by Victor Yiu, July 1993  ■  Idea from"+_
" Calvin French's HEXVIEW "
COLOR 15, 1
PRINT CHR$(218); CHR$(196); CHR$(180);
COLOR 15, 3: PRINT " "; COMMAND$; " "; : COLOR 15, 1
PRINT CHR$(195); STRING$(80 - POS(0), 196); CHR$(191)

FOR Lin = 3 TO LastDataLine
    LOCATE Lin, 1: PRINT CHR$(179); SPACE$(78);

    IF Lin = 3 THEN
        PRINT CHR$(24);
    ELSEIF Lin = LastDataLine THEN
        PRINT CHR$(25);
    ELSE
        PRINT CHR$(176);
    END IF
NEXT

LOCATE 4, 80, 0: PRINT CHR$(219);
LOCATE 24, 1: PRINT CHR$(192); CHR$(196); CHR$(180);
COLOR 13: PRINT "       (     )/"; LTRIM$(STR$(LOF(1)));
COLOR 15: PRINT " "; CHR$(195); STRING$(80 - POS(1), 196);_
 CHR$(217);

LOCATE 25, 1: COLOR 14, 3
PRINT " Adjust Viewport "; : COLOR 15
PRINT "[PgUp/PgDn] [Up/Down] [Home/End]         [F]=Filter"+_
" [Esc]=Quit ";

END SUB

SUB DrawScreen
STATIC NotOnePage, L    ' 1=True, 2=False, 0=first call

IF NotOnePage = 0 THEN
    IF LOFile& - 16 < PageSize THEN
        NotOnePage = 1
        L = (LOFile& - 1) \ 16 + 3
    ELSE
        NotOnePage = 2
        L = LastDataLine
    END IF
END IF

ShowHex Pointer&
COLOR 14

Temp& = Pointer&
FOR Row = 0 TO L - 3
    SuperHex VidSegment, Row + 3, 10, 62, Signed(sseg(Array&(0))_
 + Temp& \ 16), VARPTR(Array&(0)), Attrib, FilterOn

    LOCATE Row + 3, 3, 0
    PrintHex Temp&

    Temp& = Temp& + 16
NEXT

IF Temp& > LOFile& THEN AdjustLastBytes L

END SUB

FUNCTION GetAdapterSeg
    DEF SEG = 0
    ColorM = (PEEK(&H410) AND 48) <> 48
    DEF SEG 'Monocrome--^                       ^
            'Color Graphics Adapter or better --|

    IF ColorM THEN GetAdapterSeg = &HB800 ELSE GetAdapterSeg = &HB000
END FUNCTION


SUB LoadFile (LOFile&)

Dummy& = FRE("")

TempStor$ = SPACE$(Block)
Start& = sseg(Array&(0))

FOR LoadUp = 1 TO LOFile& \ Block
    GET #1, , TempStor$
    MemCopy sseg(TempStor$), SADD(TempStor$), Signed(Start&), VARPTR(Array&(0)), Block
    Start& = Start& + Block \ 16
    ShowHex LoadUp * 1& * Block
NEXT

TempStor$ = SPACE$(LOFile& MOD Block)
GET #1, , TempStor$
MemCopy sseg(TempStor$), SADD(TempStor$), Signed(Start&), 0, LEN(TempStor$)
    ' *** SSEG to sseg for QB/QBASIC users!
END SUB

SUB PrintHex (Num&)

    'PRINT MID$(HEX$(Num& + &H100000), 2);
    PRINT RIGHT$("0000" + HEX$(Num&), 5);

END SUB

SUB ShowHex (Posit&) STATIC

COLOR 15, 1
LOCATE 24, 5
PRINT USING "######"; Posit&;
LOCATE , 12
PrintHex Posit&

LOCATE LastBox, 80
PRINT CHR$(176);
LastBox = Posit& * 18 \ LOFile& + 4
LOCATE LastBox, 80
PRINT CHR$(219);

END SUB

FUNCTION Signed (Num&)

    IF Num& > 32767 THEN
        Signed = Num& - 65536
    ELSE
        Signed = Num&
    END IF

END FUNCTION


'
Msg #:  693                       QUIKBAS Subboard
 From:  VICTOR YIU                Sent: 07-12-93 13:40
   To:  ALL                       Rcvd: -NO-
   Re:  BROWSER 1.0 [OBJ] 1/1

' =========== Notice: this PostIt! script can't be extracted
' by the new version of PostIt! posted by Rich.  You'll have to
' run this through QB.
'
DEFINT A-Z:DIM SHARED B,K,S,B&,Z&:XA '** by PostIt! 7.0 **
SUB XA:OPEN "O",1,"SUPERHEX.OBJ",4^6:Z&=321:?STRING$(50,177);
U"&O/%-%xzuj#wmj'*se,%%%)ht#ijigd,%7f%%''&(,_I%%%&-x%zujw.mj'%%%%
U",r%jrht:u(+%%%+xh%wtqqBI%%&,oj%&#%%zZKeC%&'=k7m8C),uuo\JYYX;>EL
U"/%Y5U-ZsZ\-3pJT\(tRAM+%DjG%z%kz%z%kz%z%kz%z%kz%z%kz%z%kz%z%kz%z
U"%bzd?275%4E;M_%]*QK.]EqN*z?[md*f)Sz[3fZ-5=pJ\&WSZs-B25%Y-U3,.B6
U"UU_o05%-=%op_E?M(_a';__\M''[j&aYuPY\zY<#z)E;zRr.nC)[Qfd(z[3L.-D
U",,C5%:zZeCV%&uZRs+=M4->E16JbB&Pslt.e-D,C#/%zZ3eYM+B1&+OAM-%Cs'w
U"=27''3qF;F5,BC)%R&Y'%%&C"
END SUB
CLOSE:?:IF S=171AND B&=Z&THEN?":) Ok!"ELSE?":( Bad!
SUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:B=B-1:IF C<0THEN
C=91+C*32
S=(S+C)*2:IF B<0THEN B=4:K=C ELSE?#1,CHR$(C+(K MOD
3)*86);:K=K\3:B&=B&+1
S=S\256+(S AND 255):NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUB

' To make a LIB and QLB out of this file:
'
' LIB SUPERHEX +SUPERHEX;
' LINK /QUI SUPERHEX.LIB,,,c:\qb\bqlb45;
'                          qbxqlb        for PDS (I think)
'                          vbdosqlb      for VBDOS
' Load into QB:
'    QB BROWSER /L SUPERHEX /AH
'
' Instructions on how to make EXE file is in the BASIC source.
'
'

Msg #:  694                       QUIKBAS Subboard
 From:  VICTOR YIU                Sent: 07-12-93 13:43
   To:  ALL                       Rcvd: -NO-
   Re:  BROWSER 1.0 [ASM] 1/2

; All:
;
; This code is different from my original posting of SuperHex
; very slightly only.  I added a mem. copy and a scrolling
; procedure.
;              -- Victor

; =========== SuperHEX 1.1 ===============
; by Victor Yiu, July 1993
;
; Ultra-fast ASCII to HEX conversion...
; designed for calling up from a file
; or memory viewer to display hex/ascii
; codes like Norton's DiskEdit, or PCTool's
; View... except much faster!
;
; This code is released into public domain.
; =========================================

CODE SEGMENT PARA PUBLIC 'CODE'
    PUBLIC SuperHex, MemCopy, Scroll
    ASSUME CS:code, DS:nothing, ES:nothing, SS:nothing

CharsPerLine    = 80        ; set-up hard coded constant
FilterReplaceChar   EQU '.' ; replace bad chars. with what?

SuperHex PROC FAR
    PUSH BP             ; set up stack frame
    MOV BP, SP
    PUSH DS             ; save registers
    PUSH SI
    PUSH DI
; =============================================================
;VidSeg, Row, OffsetHex, OffsetASCii, Seg:Off memory (16 byte)
; BP+20  BP+18  BP+16       BP+14            BP+10 [DWORD]

; BG Color    Filter
;   BP+8       BP+6
; =============================================================

    LES AX, SS:[BP+18]  ; VidSeg --> ES
    DEC AX              ; Row --> AX  (adjust to 0-24 range)
    JZ NoMul            ; if 0, don't multiply to save time
    MOV BL, CharsPerLine; get # chars per line
    MUL BL              ; multiply
NoMul:
    SHL AX, 1           ; *2: vid.mem. alternates ASCii/color
    MOV DX, AX          ; save into DX

    LDS SI, SS:[BP+10]  ; get source memory into DS:SI
    PUSH SI             ; save it for later

; ====== Setup to write the 16 bytes of ASCii first
    MOV AH, SS:[BP+8]   ; get attribute into AH
    MOV DI, DX          ; move start of row offset into DI
    MOV BX, SS:[BP+14]  ; get offset of ASCii
    DEC BX
    SHL BX, 1           ; *2 because of vid. mem.
    ADD DI, BX          ; compute final offset
    CMP WORD PTR [BP+6], 0       ; filter on?
    JNE FilterOn

REPT 16                 ; repeat 16 times
    LODSB               ; get byte
    STOSW               ; store byte + attribute
ENDM
    JMP SHORT Continue
EVEN
FilterOn:
    MOV CX, 16
    MOV BX, '~ '        ; preload constants
EVEN
FilterTop:
    LODSB
    CMP AL, BL          ; below 32?
    JL NoShow
    CMP AL, BH          ; more than 127
    JG NoShow
    STOSW
    LOOP FilterTop
    JMP SHORT Continue
EVEN
NoShow:
    MOV AL,FilterReplaceChar
    STOSW
    LOOP FilterTop


; ======= Set up for HEX conversion to screen
Continue:
    MOV BX, SS:[BP+16]  ; get offset of HEX
    DEC BX
    SHL BX, 1           ; *2 for vid. mem
    ADD DX, BX          ; add to original row offset
    MOV DI, DX          ; put it into the index register
    POP SI              ; get previous SI
    MOV CX, 16          ; do sixteen characters

    MOV BL, AH          ; attribute into BL

    MOV DX, (256*9) + ('A'-'9'-1)
    MOV BP, '00'        ; preload stuff to make it scream

; BP = '00'
; BL = attribute
; BH = -- reserved for temporary digit
; DL = 'A'-'9'-1
; DH = 9
EVEN
LoopTop:
    MOV BH, 16          ; load divisor
    LODSB               ; get character
    MOV AH, 0           ; clear AH
    DIV BH              ; to get tens in AL, ones in AH.
    CMP AL, DH          ; > '9'?
    JLE NextDigit       ; no -- don't fix
EVEN
    ADD AL, DL          ; fix it
NextDigit:
    CMP AH, DH          ; > '9'?
    JLE WriteOut        ; no -- don't fix
    ADD AH, DL          ; fix it
WriteOut:
    ADD AX, BP          ; add '00' to digits to make them ASCii
    MOV BH, AH          ; save ones digit for next character
    MOV AH, BL          ; get attribute
    STOSW               ; write digit
    MOV AL, BH          ; get next
    STOSW               ; write
    MOV AL, ' '         ; write space
    STOSW
    CMP CX, 9           ; between the 8th and 9th HEX digits
    JE AddSpace
    LOOP LoopTop
    JMP SHORT OttaHere
EVEN
AddSpace: STOSW
    LOOP LoopTop

OttaHere:
    POP DI              ; restore registers
    POP SI
    POP DS
    POP BP
    RET 16       ; shave off 16 bytes of passed in parameters
SuperHex ENDP

MemCopy PROC FAR
    PUSH BP
    MOV BP, SP          ; set up stack frame
    PUSH DS
    PUSH SI
    PUSH DI

    CLD
    MOV CX, [BP+6]      ; # to copy in CX
    LES DI, [BP+8]      ; get dest.
    LDS SI, [BP+12]     ; get source

    SHR CX, 1           ; odd byte
    JNC CopyStart
    MOVSB
CopyStart: REP MOVSW    ; do copy

    POP DI
    POP SI
    POP DS
    POP BP
    RET 10
MemCopy ENDP

Scroll PROC FAR
    PUSH BP
    MOV BP, SP      ; set up stack frame

; BP+8 = MoveUp?   BP+6 = attribute

    MOV BH, [BP+6]  ; load up attribute
    MOV AX, 0601h   ; 1 line
    CMP BYTE PTR [BP+8], 0    ; zero?
    JE Down        ; yes; go up
    INC AH          ; go down (AX=0701)
Down:
    MOV CX, 0202h   ; (3,3) top left
    MOV DX, 0164Ch  ; (23,77) bottom right
    INT 010h        ; call vid. interrupt
    POP BP
    RET 4

Scroll ENDP
    CODE ENDS
END

'


 From:  AARON LAPIKAS             Sent: 07-07-93 17:02
   To:  MARK PRUITT               Rcvd: -NO-
   Re:  CRCS

Hi Mark!

 > My questions are:

Only three?  :)

> Does a '32 bit CRC' turn out the same no matter who's code generates it?
> In other words... is there only ONE '32 bit CRC' for a given chunk o' data?

As far as I know, yes.  If it weren't that way, how could it be used as
a method of error checking?

> Will the 32 bit CRC of my name turn out completely unique from the other
> several hundred users of the same bbs?  Since I have NO idea of even what a
> 32 bit CRC is, much less the math that goes into it, it seems to me that a
                                   ...

Yes.  The chances of having two different pieces of data with the same
CRC are very small, if not next to none.

 > Could someone post "their way of calculating a 32 bit CRC" with a
 > layman's (read that: lame brain's) explanation of what the code is
 > doing?

'-----------------------------------------------------------------------

DECLARE FUNCTION CRC32% (Target$)

DEFINT A-Z
FUNCTION CRC32 (B$)

DIM CRC AS LONG
CRC = 0

FOR I = 1 TO LEN(B$)                           'Calculate for Length of
Block
  ByteVal = ASC(MID$(B$, I, 1))

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 128) = 128)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 64) = 64)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 32) = 32)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 16) = 16)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 8) = 8)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 4) = 4)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 2) = 2)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&

  TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND 1) = 1)
  CRC = ((CRC AND 32767&) * 2&)
  IF TestBit THEN CRC = CRC XOR &H8005&
NEXT I

CRC32% = CRC

CRCHigh% = (CRC \ 256)                          'Break Word Down into
Bytes
CRCLow% = (CRC MOD 256)                         'for Comparison Later
ComputeCRC& = CRC                               'Return the Word Value

END FUNCTION
'-----------------------------------------------------------------------

'

 From:  STEVE DEMO                Sent: 07-05-93 15:32
   To:  PAUL SENECHKO             Rcvd: -NO-
   Re:  (R)DIRECTORIES IN QB 4.

 -=> Quoting Bill Smith to Paul Senechko <=-

 PS>Hi all, I am looking for a way in Quick Basic 4.5 to put all of the
 PS>directories on the current drive into a file.  Any ideas?

 BS> How about SHELL TREE>file.nam

 Ha, Ha, Ha, Ha, Ha,  That's a good one. Now Listen up Paul I didn't
write this it's about as HOT as the day is :-). I converted it back to
QB for ya.

Steve Demo

'$INCLUDE: 'qb.bi'
DECLARE SUB Tree (drive$, Count!, Array$())
DEFINT A-Z
CONST DOS = &H21
CONST SetDTA = &H1A00, FindFirst = &H4E00, FindNext = &H4F00  ' These
Const are for Tree sub
DIM Array$(500)
Tree "C:\", Count!, Array$()
FOR x = 1 TO Count! STEP 1
  IF Array$(x) = "" THEN END
  PRINT Array$(x)
NEXT x

SUB Tree (drive$, Count!, Array$())

DIM r AS RegTypeX
search$ = drive$                                   'reassign string
since it
IF Count! = 0 THEN                                  ' gets changed in
routine
  search$ = UCASE$(search$)                        'make upper case
  IF LEN(search$) = 1 THEN search$ = search$ + ":" 'define search
  search$ = LEFT$(search$, 2)
  Count! = 1
  Array$(Count!) = search$ + "\"
END IF

zero$ = CHR$(0): DTA$ = SPACE$(43) '43    'define ZERO and DTA
search$ = search$ + "\"
srch$ = search$ + "*" + zero$          'dos requires zero terminated
string

'get original dta
r.ax = &H2F00
INTERRUPTX &H21, r, r
sgmt = r.es: ofst = r.bx               'save segment and offset of dta
mode = &H4E00                          'set mode to FINDFIRST

'set our dta
DO
 r.ax = &H1A00
 r.ds = VARSEG(DTA$): r.dx = SADD(DTA$)  'change SSEG to VARSEG in qb
 INTERRUPTX &H21, r, r                 'tell dos where this dta is

 r.ax = mode                           'findfirst, or findnext
 r.cx = 16                             'look for directories
 r.ds = VARSEG(srch$): r.dx = SADD(srch$)'change SSEG to VARSEG in qb
 INTERRUPTX &H21, r, r                 'find one
 IF (r.flags AND 1) THEN EXIT DO       'if none, bail
 f.attr = ASC(MID$(DTA$, 22))          'attribute in f.attr
 tmp$ = MID$(DTA$, 31) + zero$
 f.name$ = LEFT$(tmp$, INSTR(tmp$, zero$) - 1)  'directory name in
f.name
 mode = &H4F00                         'change mode to FINDNEXT
 IF ASC(f.name$) <> 46 THEN            'we don't want '.' or '..'
   IF f.attr = 16 THEN                 'make sure it's a directory
  Count! = Count! + 1                 'increment Count!
  s$ = search$ + f.name$            'full path name
  Array$(Count!) = s$                'add to array
  Tree s$, Count!, Array$()     'look for some dirs here
   END IF
 END IF
LOOP
r.ax = &H1A00
r.ds = sgmt: r.dx = ofst               'return original dta segment &
offset
INTERRUPTX &H21, r, r
END SUB
'

'Msg #:  730                       QUIKBAS Subboard
' From:  SCOTT WUNSCH              Sent: 07-11-93 10:48
'   To:  ALL                       Rcvd: -NO-
'   Re:  READBAS1.BAS
'
'Salutations, All!
'
'  This might come in handy to someone here...
'
'  Area: NET140.TECH
'  From: Frank Cox, 1:140/53 (10 Jul 93 10:18)
'  To:   Whoever cares
'  Subj: READBAS1.BAS
'__________O_/________________/ SNIP \__________________\_O__________
'          O \                \ HERE /                  / O
'This just came around in the DR_DEBUG echo and I thought it was worth
'passing along.
'
'Problem:  You have some GWBASIC source code which has been saved in
'tokenized format, and you don't have a copy of GWBASIC to use to
'convert it into an ASCII file for use under QBASIC or whatever.  This
'is a common problem as GWBASIC is not distributed with MS-DOS 5.0 and
'up.

'Solution:  This old program (which appears to run fine under QBASIC):

1 ''            READBAS 1.1 -  READS BASIC PROGRAMS SAVED IN BINARY
2 ''        NELSON FORD [phone]   [phone]    APRIL 11,1985
3 ''
4 '' PUBLIC DOMAIN.  The idea is to compile this program and use it while in
5 '' DOS to look at BASIC programs that have been saved in binary format.  The
6 '' compiled version of this is not being uploaded due to the inordinate
7 '' amount of difficulty and expense required to make a go
10 DEFINT A-Z:  CLS: INPUT "FILE NAME"; FI$
20 INPUT "TO (1)SCREEN (2)PRINTER (3)DISK"; D
30 IF D=1 THEN F2$="SCRN:" ELSE IF D=2 THEN F2$="LPT1:" ELSE IF D=3
THEN INPUT_ "OUTPUT FILENAME"; F2$ ELSE 20
40 DIM X#(8): PRINT: PRINT "PRESS ANY KEY TO ABORT": PRINT
50 DIM T$(115), T3$(6), T4$(30), T5$(37)
60 FOR T=129 TO 243: READ T$(T-128):  NEXT   'tokens 129-243
70 FOR T=129 TO 134: READ T3$(T-128): NEXT   'token 253 followed by 129-134
80 FOR T=129 TO 158: READ T4$(T-128): NEXT   'token 254 followed by 129-158
90 FOR T=129 TO 165: READ T5$(T-128): NEXT   'token 255 followed by 129-165
95 '
100 OPEN FI$ AS 1 LEN=1:  FIELD 1, 1 AS X$
110 OPEN F2$ FOR OUTPUT AS #2:  GET 1
120 IF ASC(X$) <>255 THEN PRINT "NOT A BASIC PROGRAM SAVED IN BINARY":END
125 '----get, print line number:
130 GET 1: X=ASC(X$): GET 1: IF X=0 AND ASC(X$)=0 THEN STOP
140 GET 1: N$=STR$(ASC(X$)):  GET 1: X=ASC(X$)
150 IF X>0 THEN N$=STR$(X*256+VAL(N$))
160 PRINT #2, RIGHT$(N$,LEN(N$)-1) " ";
190 '----get a hex character and translate:
200 GET 1: X= ASC(X$)
210 U$=INKEY$: IF U$<>"" THEN END
220 IF X=58 THEN GET 1: X=ASC(X$): IF X=143 THEN GOSUB 910: GOTO 130 ELSE IF _ X<>161 THEN PRINT #2,":";
230 IF X=0  THEN PRINT #2,"": GOTO 130    'ascii 0 marks end of BASIC line
240 IF X>31 THEN 300  ELSE IF X <11 THEN STOP
250   ON X-10 GOSUB
400,440,480,500,540,580,600,600,600,600,600,600,600,600, 600,600,640,660,720,815 ,820
260   GOTO 200
270   RETURN
290 '------
300 IF X <128 THEN PRINT #2, X$;:  GOTO 200
310 IF X >128 AND X <244 THEN PRINT #2, T$(X-128);:  GOTO 200
320 IF X >252 AND X <256 THEN GET 1: Y=ASC(X$) ELSE 200
330 IF Y <129 THEN PRINT "ERROR IN FILE": STOP
340 ON X-252 GOTO 350,360,370:  GOTO 200
350   PRINT #2, T3$(Y-128);:  GOTO 200
360   PRINT #2, T4$(Y-128);:  GOTO 200
370   PRINT #2, T5$(Y-128);:  GOTO 200
390 '
400 GET 1: N=X: GET 1: N=X*256 +N    '11  =  OCTAL
410 PRINT #2, "&O" OCT$(N);
420 RETURN
430 '
440 GET 1: N=X: GET 1: N=X*256 +N    '12  =  HEX
450 PRINT #2, "&H" HEX$(N);
460 RETURN
470 '
480 STOP                             '13  NOT USED
490 '
500 GET 1: N$=STR$(ASC(X$))          '14  INTEGERS
505 GET 1: X=ASC(X$)

510 IF X>0 THEN N$=STR$(X*256+VAL(N$))
520 PRINT #2, RIGHT$(N$,LEN(N$)-1);
530 RETURN
535 '
540 GET 1: N$=STR$(ASC(X$))          '15  =  NUMBERS 10 TO 255
550 PRINT #2, RIGHT$(N$,LEN(N$)-1);
560 RETURN
570 '
580 STOP                             '16  NOT USED
590 '
600 N$=STR$(X-17)                    '17 - 26 = NUMBERS 0 TO 9
610 PRINT #2, RIGHT$(N$,LEN(N$)-1);
620 RETURN
630 '
640 STOP                             '27  NOT USED
650 '
660 GET 1: N=ASC(X$): GET 1          '28  =  NUMBERS > 255 AND <32267
670 N$= STR$(256*ASC(X$) +N)
680 PRINT #2, RIGHT$(N$,LEN(N$)-1);
690 RETURN
700 '
710                                  '29  =  NUMBERS >32267 AND < ?
720 FOR I=1 TO 4: GET 1: X#(I)=ASC(X$): NEXT:  Z$=""
730   FOR J=3 TO 1 STEP -1:  Y#=X#(J)
740     FOR I= 7 TO 0 STEP-1
750 IF Y# > 2^I-1 THEN Z$=Z$+"1": Y#=Y#-2^I ELSE Z$=Z$+"0"
760     NEXT
770   NEXT:  N#=1:  Z$=RIGHT$(Z$,23)
780 FOR I=1 TO 23: N#= N# + VAL(MID$(Z$,I,1)) * .5^I:  NEXT
790 N$=STR$(N# * 2^(X#(4)-129)): PRINT #2, RIGHT$(N$,LEN(N$)-1); "!";
800 RETURN
815 '        30  NOT USED
816 '
819 '                                 31  =  DOUBLE PRECISION
820 FOR I=1 TO 8: GET 1: X#(I)=ASC(X$): NEXT:  Z$=""
830   FOR J=7 TO 1 STEP -1:  Y#=X#(J)
840    FOR I= 7 TO 0 STEP-1
850 IF Y# > 2^I-1 THEN Z$=Z$+"1": Y#=Y#-2^I ELSE Z$=Z$+"0"
860     NEXT
870   NEXT:  N#=1: Z$=RIGHT$(Z$,55)
880 FOR I=1 TO 55:  N#= N# + VAL(MID$(Z$,I,1)) * .5^I:  NEXT
890 N$=STR$(N# * 2^(X#(8)-129)):  PRINT #2, RIGHT$(N$,LEN(N$)-1); "#";
900 RETURN
905 '                        read from ' to end of line:
910 PRINT #2, "'";:  GET 1:
920 GET 1: IF ASC(X$) >0 THEN PRINT #2, X$;: GOTO 920
950 PRINT #2, "": RETURN
955 '
960 'tokens 129-244:
970 DATA
END,FOR,NEXT,DATA,INPUT,DIM,READ,LET,GOTO,RUN,IF,RESTORE,GOSUB,RETURN
980 DATA
REM,STOP,PRINT,CLEAR,LIST,NEW,ON,WAIT,DEF,POKE,CONT,NU,NU,OUT,LPRINT
990 DATA LLIST,NU,WIDTH,ELSE,TRON,TROFF,SWAP,ERASE,EDIT,ERROR,RESUME,DELETE
1000 DATA AUTO,RENUM,DEFSTR,DEFINT,DEFSNG,DEFDBL,LINE,WHILE,WEND,CALL,NU,NU,NU
1010 DATA  WRITE,OPTION,RANDOMIZE,OPEN,CLOSE,LOAD,MERGE,SAVE,COLOR,CLS,MOTOR
1020 DATA BSAVE,BLOAD,SOUND,BEEP,PSET,PRESET,SCREEN,KEY,LOCATE,NU,TO,THEN,TAB(
1030 DATA STEP,USR,FN,SPC,NOT,ERL,ERR,STRING$,USING,INSTR,"'",VARPTR,CSRLIN
1040 DATA POINT, OFF,INKEY$,NU,NU,NU,NU,NU,NU,NU,>,=,<,+,-,*,/,^,AND,OR,XOR,EQV
1050 DATA IMP,MOD
1060 'pre-token 253, tokens 129-134:
1070 DATA CVI,CVS,CVD,MKI$,MKS$,MKD$
1080 'pre-token 254, tokens 129-158:
1090 DATA FILES,FIELD,SYSTEM,NAME,LSET,RSET,KILL,PUT,GET,RESET,COMMON,CHAIN
1100 DATA DATE$,TIME$,PAINT,COM,CIRCLE,DRAW,PLAY,TIMER,ERDEV,IOCTL,CHDIR,MKDIR
1110 DATA RMDIR,SHELL,ENVIRON,VIEW,WINDOW,PMAP
1120 ' pre-token 255, tokens 129-165:
1130 DATA LEFT$,RIGHT$,MID$,SGN,INT,ABS,SQR,RND,SIN,LOG,EXP,COS,TAN,ATN,FRE
1140 DATA INP,POS,LEN,STR$,VAL,ASC,CHR$,PEEK,SPACE$,OCT$,HEX$,LPOS,CINT,CSNG
1150 DATA CDBL,FIX,PEN,STICK,STRIG,EOF,LOC,LOF

'


                            OBJECT ORIENTED BASIC
                          Possibility or Pipe Dream?


                           an explorative article


        TABLE OF CONTENTS

        1.0 Introduction
        1.1 Key Terminology and Concepts
        2.0 BASIC-Specific Considerations of Object Paradigm Implementation
        2.1 Standardization of Terms in Object Oriented BASIC
        2.2 An Introduction to Advanced Topics in OOP
        3.0 Closing Notes

=======================================================================


1.0     Introduction


BASIC has evolved from the time-sharing "Beast of Dartmouth" into a
powerful, structured language fit for the programming needs of the
nineties.  Despite this evolution, however, major software compiler
developers have failed to introduce object oriented extensions into
the language.

This article will explore some possible extensions to modern
BASIC that would truly expand the language.  Since, because of its
nature, this article will use a speculative approach, the reader
should bear in mind that no particular implementation is being
suggested as the "best" way to bring object-orientation to
BASIC.  Moreover, some BASIC programmers may feel that certain low
level features such as in-line assembler and more diverse data
types should be introduced into the BASIC language before object-
orientation is even considered.  These readers should remember the
theoretical nature of this discussion, and leave all such
preferences out of the exploration at hand.


1.1     Key Terminology and Concepts

First, I must define some key terms and concepts.  My use of the generic
term BASIC (Beginner's All-purpose Symbolic Instruction Code) will,
unless otherwise stated, refer to the Microsoft QuickBASIC v4.5 dialect
of BASIC, since this represents a widely accepted implemenation of
modern, structured BASIC.  The term OOP (Object Oriented Programming)
will be used to refer to those programming practices that rely on the
object paradigm.  Although the terminology differs from compiler to
compiler, the object oriented paradigm is considered by modern usage to
intrinsically encompass the following concepts, to be defined later:

    1.  Encapsulation
    2.  Inheritence
    3.  Polymorphism
    4.  Overloading

Therefore, when I say that a given concept is "object oriented" I
specifically mean that it involves the above four concepts.
Other important terms that cannot be ignored in any discussion of OOP,
due to their repeated use in the discussion of such are:

    5.  Class
    6.  Method (or Member Function)
    7.  Object (or Class Instance)
    8.  Information or Data Hiding

Not able to decide which term to define first, I will begin with a
general overview fo the underlying philosophy of OOP.

In classical structured programming, data and code are considered
separate entities.  Code manipulates data.  Data fuels code.  For
example, wanting to implement a graphics font engine, a classical
BASIC programmer might read a list of DATA statements into a globally
accessible array, and then have a series of globally accessible
SUBPROGRAMS manipulate those raster data on the screen in such a
way as to produce the desired visual effect.  The problem with this
approach is that both the data and the related code are equally
accessible, and they are only loosely cohesive.  Wanting to enhance
code written by a colleague, a second programmer will encounter
data structures that he should neither modify nor even poll, but
that may not always be possible.  Having modified an essential
data structure, the second programmer may introduce errors
into the whole underlying logic of the system.

For instance, suppose the original programmer had defined the
font data structure thus:

    TYPE FontDataType
        FontName AS STRING * 12
        FontPointSize AS INTEGER
        RasterDataPtr AS LONG
    END TYPE

Now, looking at this, Programmer Two decides that he can avoid a
FUNCTION call to funGetFontPointSize() by just reading the value of
Font.FontPointSize directly.  Programmer Two alters his code to
access this variable directly, and in doing so, avoids what he
considers costly calls to funGetFontPointSize().  He is
promoted to another department (presumably for having sped up the
code of his predecessor).  Enter Programmer Three.  Quite within
his bounds, he discovers that point size is never greater than 255,
and so redefines the whole structure to account for this, thereby
reducing overall memory consumption by one byte:

    TYPE FontDataType
        FontName AS STRING * 12
        FontPointSize AS STRING * 1
        RasterDataPtr AS LONG
    END TYPE

Of course, being conscientious, he modifies funGetFontPointSize()
to account for this innovation.  He compiles the program.  It crashes.
Why?  Because, this is now an illegal statement:

    Font.FontPointSize = 12

What to do?  He must use his search and replace to go through the
entire program and change all such instances to:

    Font.FontPointSize = CHR$(12)

Or, he can forget his alterations altogether.

In BASIC, there is no INFORMATION HIDING that would prevent such
problems from occuring.  Since FontPointSize is a public member
of FontDataType, Programmer Two was well within his rights to do
as he saw fit as far as accessing it.  Had the original programmer
had an object oriented BASIC, however, he could have prevented the
entire problem with little difficulty by making FontPointSize a
PRIVATE data member of the CLASS font.  This might have looked
similar to this:

    CLASS FontClass
        FontName AS PUBLIC STRING * 12
        FontPointSize AS PRIVATE INTEGER
        RasterDataPtr AS PRIVATE LONG
        funGetFontPointSize AS PUBLIC FUNCTION
        subSetFontPointSize AS PUBLIC SUB
    END CLASS

    DIM Font AS FontClass

[Please bear with the strange new syntax, since it will be covered
in more detail in section 2.0.]

Now, the only way to access Font.FontPointSize is indirectly.  This
would NOT work, since this data member is now PRIVATE:

    Font.FontPointSize = 12

This, then, would be the ONLY way to achieve such a thing:

    Font.subSetFontPointSize 12

In the above example, the item Font is what is called a CLASS INSTANCE.
That is to say, Font is "an instance of the class FontClass." This is
what is commonly called an OBJECT, and it is from this that we arrive at
the phrase "object oriented" programming.

Now, when Programmer Two comes along, he CANNOT pull off his stunt,
and he is not promoted to another department.  Programmer Three comes
along, and sees room for improvement and redefines the class thus:

    CLASS FontClass
        FontName AS PUBLIC STRING * 12
        FontPointSize AS PRIVATE STRING * 1
        RasterDataPtr AS PRIVATE LONG
        funGetFontPointSize AS PUBLIC FUNCTION
        subSetFontPointSize AS PUBLIC SUB
    END CLASS

Since all calls to change FontPointSize are through the centralized
subSetFontPointSize, Programmer Three just modifies that a bit, and
earns himself a nice raise in salary for shaving a byte off the
memory requirements of the structure.

Consider the above example.  The data are:

    1. FontName
    2. FontPointSize

The code portions (called MEMBER FUNCTIONS or METHODS, since they
are "methods of acting upon or accessing" the data) are:

    1. funGetFontPointSize
    2. subSetFontPointSize

Since it is unlikely that subSetFontPointSize will ever be needed for
anything other than the setting of FontPointSize, it makes sense to
bind the code to the data it works with.  This binding is called
ENCAPSULATION.

Having examined these more essential terms, there is the issue of
OVERLOADING.  Although not object oriented in the strictest sense,
it does aid in generalizing classes to an extent that they can
operate upon different types of data.

Consider the following:

    subQuickSort A%()

Now, in classical BASIC programming, if we wanted to sort anything
other than INTEGER arrays, we would have to write another SUBPROGRAM
and modify the algorithm to account for this new data type.  This
SUBPROGRAM would have to be named something other than subQuickSort.
For example:

    subQuickSortSTR A$()

might be used for STRING arrays, and

    subQuickSortLONG A&()

might be used for LONG INTEGER arrays.  And, of course, should a
programmer ever want to sort a user-defined TYPE array:

    subQuickSortUserTYPE UserArray()

would be the only way to do it.

But, consider the above.  All of these routines do the same thing.  It
seems a waste to have three names to do what amounts to the same thing:
sorting arrays.  The answer is to "overload" a SUBPROGRAM name with
three corresponding pieces of code.  Once subQuickSort is overloaded, it
can do tripple-time thus:

    subQuickSort A%()
    subQuickSort A$()
    subQuickSort UserArray()

Of course, each call invokes DIFFERENT CODE to do the actual sorting,
but this detail is handled by the compiler in a transparent fashion.
The programmer's only responsibility would be to provide the code for
each instance of subQuickSort, in the following manner:

    SUB subQuickSort (Array AS INTEGER)
        |
        |
        code to sort INTEGER arrays goes here
        |
    END SUB

    SUB subQuickSort (Array AS LONG)
        |
        |
        code to sort LONG INTEGER arrays goes here
        |
        |
    END SUB

    SUB subQuickSort (Array AS UserDefinedType)
        |
        |
        code to sort arrays of UserDefinedType goes here
        |
        |
    END SUB

Upon seeing the second instance of subQuickSort in the source listing,
the object oriented BASIC compiler would know that it is dealing with
an overloaded SUBPROGRAM.

Overloading is already done by BASIC compilers, but it is done at a
level not within the control of the programmer.  Consider:

    PRINT a
    PRINT a$

Each case of PRINT prints a different data type.  The PRINT statement,
we could say, then, is overloaded.  Also to consider is the overloading
of operators such as occurs already in BASIC:

    A$ = B$ + C$
    A% = B% + C%

The addition operator is serving two masters here.  In the first case,
it is being used to concactenate strings.  In the second, it is being
used to add two numbers.  The processes are internally dissimilar.
How, then, does the BASIC compiler contend with these cases?  The
addition operator is overloaded at an internal level.  If a programmer
using an object oriented BASIC were to step into the scene, however,
we very well might see this type of overloading of the addition and
assignment operators:


    OVERLOAD "+" FOR ArrayOne(), ArrayTwo()
        TotalElements = UBOUND(ArrayOne) + UBOUND(ArrayTwo)
        DIM ReturnArray(TotalElements)
        FOR i = 1 to UBOUND(ArrayOne)
            ReturnArray(i) = ArrayOne(i)
        NEXT i
        FOR q = i + 1 TO i + UBOUND(ArrayTwo)
            ReturnArray(q) = ArrayTwo(q-i)
        NEXT q
        REDIM ArrayOne(TotalElements)

        ' The following uses an overloaded assingment operator
        ' whose overload definition follows.
        ArrayOne() = ReturnArray()
    END OVERLOAD

    OVERLOAD "=" FOR ArrayOne(), ArrayTwo()
        FOR i = 1 TO UBOUND(ArrayOne)
            ArrayOne(i) = ArrayTwo(i)
        NEXT i
    END OVERLOAD

This bit of sophisticated operator overloading would allow the
programmers to add entire arrays to one another as follows:

    NewList() = ListOne() + ListTwo()

For some readers, all this may be a new concept in programming.  If
it seems hard to understand, please take time to reread this section
before continuing, since the next part of this discussion relies on
the reader's comprehension of all eight terms pertinent to the object
oriented programming paradigm, which are, again:

    1.  Encapsulation,
    2.  Inheritence,
    3.  Polymorphism,
    4.  Overloading,
    5.  Class,
    6.  Method (or Member Function),
    7.  Object (or Class Instance),
    8.  Information or Data Hiding.

[Polymorphism has been purposely avoided for the purposes of this
discussion, due to its rather esoteric nature.]

2.0     BASIC-Specific Considerations of Object Paradigm Implementation

When considering whether BASIC in its present form could
be expanded to include object oriented extensions, we must first look
at what is already possible in standard BASIC.  For example, the
following code resembles inheritence, at least in part:

    TYPE ColorType
        R AS INTEGER
        G AS INTEGER
        B AS INTEGER
    END TYPE

    TYPE CoordinateType
        X AS INTEGER
        Y AS INTEGER
    END TYPE

    TYPE CircleType
        Point AS CoordinateType
        Color AS ColorType
        Radius AS INTEGER
    END TYPE

This is not classical inheritence, but the analogy suffices.  Looking
at the syntactical elements of the above code, we see that a similar
structure could easily be adopted for use with CLASS definitions:

    CLASS CircleClass
        Point AS CoordinateType
        Color AS ColorType
        Radius AS INTEGER
    END CLASS

A question arises, however.  The above definition of the CircleClass
CLASS is not executable code, but merely a definition template.  It
defines CircleClass, but does not assign a "class instance."  That is
to say, there are not yet any objects of CircleClass defined in the
program.  Consider this standard BASIC:

    TYPE AddressType
        Street AS STRING * 10
        City AS STRING * 32
        State AS STRING * 2
        ZIP AS STRING * 12
    END TYPE

    DIM Envelope AS AddressType

The DIM statement is used to create an instance of a variable
called Envelope that is of the user defined type AddressType.  It
makes perfect sense, then, that the DIM statement could be used
in this manner:

    CLASS CircleClass
        Point AS CoordinateType
        Color AS ColorType
        Radius AS INTEGER
    END CLASS

    DIM Orb AS CircleClass

(Remember, having DIM serve this double purpose is known as
overloading the DIM statement.)  This syntax serves our purposes
wonderfully, since it does not involve the introduction of completely
foreign operators and follows the present syntactical structure of
standard BASIC.

Another consideration in the creation of classes is the fact that
classes may contain both variables and methods in their definitions,
as shown in the introduction:

    CLASS FontClass
        FontName AS PUBLIC STRING * 12
        FontPointSize AS PRIVATE INTEGER
        RasterDataPtr AS PRIVATE LONG
        funGetFontPointSize AS PUBLIC FUNCTION
        subSetFontPointSize AS PUBLIC SUB
    END CLASS

This shows a suggested means of expressing both the scope and the
type of each part of the definition.  Note, however, that, although
subSetFontPointSize is defined in this template, there is, as yet,
no code attached to the definition.  It is said, in OOP parlance, that
the "the scope of the member function is unresolved."  The method is
prototyped, but that is all.  In C++, what is known as the "scope
resolution operator" is used to resolve a method, that is, assign
executable code to it.  This is done as follows:


    void FontClass::subSetFontPointSize (int PointSize)
    {
    |
    code to achieve this end goes here
    |
    }

Essentially, this translates into the English statement:

    "Define funGetFontPoint size of the class FontClass as follows...."

In an attempt to avoid convoluted syntactical introductions into the
BASIC language, what follows is a possible solution:

    SUB FontClass.subSetFontPointSize (PointSize AS INTEGER)
        |
        |
        code that assigns the point size goes here
        |
        |
    END SUB

Since the compiler would presumably recognize FontClass as being a
class from the earlier CLASS ... END CLASS block, this should suffice
as a means of resolving the scope of the method subSetFontPointSize,
while avoiding the introduction of :: as a new BASIC operator.

Next comes the issue of overloading both keywords and operators.  A
simple extension of BASIC would allow this to be sufficient in the
case of SUBPROGRAMS and FUNCTIONS:


    SUB subQuickSort (Array AS STRING)
        |
        |
    END SUB

    SUB subQuickSort (Array AS INTEGER)
        |
        |
    END SUB


The second SUB definition would imply overloading. This would be
prototyped at the beginning of the source listing thus:

    DECLARE SUB subQuickSort (Array AS STRING)
    DECLARE SUB subQuickSort (Array AS INTEGER)

Operators, however, are completely different in that BASIC has
no way of referring to them explicitly.  A proposed extension:

    OVERLOAD "=" FOR LeftArgument, RightArgument
        |
        |
        definition code goes here
        |
        |
        result returned in LeftArgument
        |
        |
    END OVERLOAD

Of course, the "=" could be any ASCII character or even multiple
ASCII characters.  This would allow the object oriented BASIC program
to do this, for example:

    OVERLOAD "**" FOR LeftArgument, RightArgument

        ' Some langauges use ** for raising to a power
        LeftArgument = LeftArgument ^ RightArgument

    END OVERLOAD

The following, however, would not be possible, since it would involve
late binding and interpreted evaluation at run-time:

    OVERLOAD Operator$ FOR LeftArgument, RightArgument
        SELECT CASE Operator$
            CASE "**"
                LeftArgument = LeftArgument ^ RightArgument
            |
            |
            etc.
            |
            |
        END SELECT
    END OVERLOAD



2.1     Standardization of Terms in Object Oriented BASIC

Before the discussion continues, perhaps it would be wise to step
aside to establish a set of standard terms.  Since certain
OOP concepts carry many different names (ie. "member function" is
also "method") a standard way of refering to any particular device
should be adopted.  But, really, this could become quite involved;
what is more appropriate, the term "method" or "member function?"
Perhaps, rather than debate too long and hard on the subject,
Microsoft's terminology as used for Visual Basic should be adopted:

    1.  OBJECT rather than "class instance"
    2.  METHOD rather than "member function"
    3.  PROPERTY rather than "member variable"

For terms not used by Visual Basic, I suggest the following use by
object oriented BASIC:

    1.  DATA HIDING rather than "information hiding"
    2.  METHOD DECLARATION rather than "scope resolution"
    3.  METHOD DECLARATOR rather than "scope resolution operator"
    4.  OBJECT BINDING rather than "encapsulation"
    5.  OVERLOADING remains unchanged
    6.  CLASS remains unchanged

I use these substitutes for the other terms because they have a
BASIC sound to them, whereas the other terms, like "scope resolution
operator" may sound odd to BASIC programmers.  DECLARATOR rings of
BASIC's DECLARE statement, thereby reducing the foreigness of the
term METHOD DECLARATOR.  (In case you have forgotten, the :: is
the scope resolution operator in C++, whereas the . is used in this
theoretical object oriented BASIC of ours.)

Using this terminology, we have this model:

      / CLASS VectorClass  ' This is a CLASS DECLARATION
      |     X AS PRIVATE INTEGER   ' This is a PROPERTY of VectorClass
 O B  |     Y AS PRIVATE INTEGER   ' As is this
 B I  |     '    ^^^^^^
 J N  |     ' Use of PRIVATE demonstrates DATA HIDING
 E D  |     ' Whereas use of PUBLIC demonstrates the oposite--\
 C I  |     '                                                 |
 T N  |     '                 /-------------------------------/
   G  |     '               VVVVVV
      |     subSetVector AS PUBLIC SUB ' This is a METHOD
      \ END CLASS

        '  This operator is the METHOD DECLARATOR in this context
        '              |
        '              V
    D / SUB VectorClass.subSetVector ( X AS INTEGER, Y AS INTEGER )
    E |
 M  C |
 E  L |
 T  A |
 H  R |
 O  A |
 D  T |
    I |
    O |
    N \ END SUB


2.2     An Introduction to Advanced Topics in OOP

To this point, most fundemental concepts of the object oriented
paradigm have been examined.  The reader should have a concept of
class, object binding, method declaration, overloading, and
data hiding, and should also understand the essence of how these
object oriented extensions may be added to BASIC.

There are other considerations, however.  When an object is created,
for instance, how is it initialized?  That is to say, how are its
properties set to appropriate starting values?  A typical standard
BASIC program might accomplish this thus:

    CALL subFontInit()

This is fine, but remember that there can be more than one OBJECT of
the same CLASS as in this case:

    DIM Helvetica AS FontClass
    DIM Courier AS FontClass
    DIM TimesRoman AS FontClass

Now, to initialize the data for each of these, we must do something
like this:

    CALL subFontHelveticaInit
    CALL subFontCourierInit
    etc.

In C++, there is away around this that we can adopt for BASIC use.
In every class in C++ there is an implied "constructor."  This is
a new term.  Essentially, the constructor is a method within the
class definition that is executed whenever an object is created.
For an example of this, consider this method declaration:

    SUB FontClass.FontClass
        |
        |
        code to initialize object goes here
        |
        |
    END SUB

(Visual Basic programmers will recognize this as being analogous to
the Load_Form event.)  Note that the method declaration uses FontClass
twice.  This informs the compiler that it is dealing with the explicit
definition of a CONSTRUCTOR.

In the actual binding declaration of the class, this syntax is
suitable:

    CLASS FontType
        |
        etc.
        |
        FontType AS CONSTRUCTOR
        |
        etc.
        |
    END CLASS

The CONSTRUCTOR type then, signifies that this template will be
followed by a method declaration for a constructor.  Now, when the
programmer includes this code:

    DIM Helvetica AS FontType

The compiler will include appropriate initialization routines.

Another aspect of this, the "destructor," is exactly the same, except
that it operates after the object falls from scope.  (Visual Basic
programmers again will note the analagous use of the Form_Unload event.)
Destructors deinitialize data, cleaning up things when the program ends
execution, for instance.  In C++, a special operator is used to indicate
the deconstructor: ~FontClass.  This use of the tilde is foreign to
BASIC, however, so perhaps it would be better to introduce another
keyword rather than a new operator:

    CLASS FontType
        |
        etc.
        |
        FontType AS CONSTRUCTOR
        FontType AS DESTRUCTOR
        |
        etc.
        |
    END CLASS

Now, the method would simply be declared:

    SUB FontType.FontType DESTRUCTOR
        |
        |
        code to deinitialize data structures goes here
        |
        |
    END SUB

This is syntacally familiar to a BASIC programmer in another form:

    SUB subPrintToScreen (InText AS STRING) STATIC
        |
        |
    END SUB

The STATIC keyword modifies the nature of the SUBPROGRAM.  Consquently,
I have suggested the DESTRUCTOR keyword be used in a similar syntactical
fashion.

3.0     Closing Notes

Indeed, BASIC has evolved from the time-sharing days of Dartmouth.
Despite this evolution, however, major software compiler developers
have failed to introduce object oriented extensions into the language.
Perhaps this article has introduced some new concepts to the reader,
perhaps not.  At the very least, it has explored some ways
an object oriented paradigm might be introduced successfully into
BASIC programming with as little pain possible.  Programmers tend to
maintain their old programming habbits despite the innovations that
come into their languages, and consequently, any major changes to
the way BASIC operates may prove to be obstacles rather than useful
tools.  I feel that my suggestions involve minimal relearning of the
syntax of BASIC, since they adopt the flavor of existing structures.
In the end, though, the question is not what is the better method
or terminology to use, really, but rather:

    "Object Oriented BASIC, possibility or pipedream?"

'

 From:  RICH GELDREICH            Sent: 07-15-93 02:59
   To:  ANDY THOMAS               Rcvd: -NO-
   Re:  (R)CALL INTERRUPT

> LA>DL> AL = AX AND &HFF
> LA>DL> AH = (AX \ &H100) AND &HFF
>
> LA>is very likely the most efficient way to do it.  I hope all
> LA>the people posting the wrong way to do it, (AH = AX\256) are
> LA>watching as well.
>
> Well, wrong is not quite the right word, as &H100 = 256 the two
> methods are equivalent. Tacking on the AND &HFF is redundant and will
> only change the value if something is wrong originally with the AX
> value. AX should be made of two bytes, and have a maximum value of
> &HFFFF only if AX is greater than this maximum value will the AND &HFF
> change anything. AH=AX\256 is a perfectly valid calculation and will
> work whenever the AX value is valid. If the AX value is invalid you
> don't want to be using it anyway! :> -Andy

    Hmmm. Seems like everybody is wrong one way or another in this
conversation... :-)

    First off, let's assume AX = &HFFFF. The correct result of shifting
AX right 8 places would be &HFF. The calculation for doing this above -
AH = (AX\&h100) AND &HFF, would *not* return &HFF, but &h0, because
(-1\&h100) = 0. (Remember QuickBASIC treats 16 bit words as signed, so
&HFFFF = -1.)

    In this context, AH=AX\256 is not a perfectly valid calculation. If
AX contains an unsigned integer, this calculation will not work
correctly all of the time.

    This calculation does work for all values of AX:

    AL = AX AND &HFF
    AH = (CLNG(AX) AND &HFFFF&) \ &H100

    The "&" after &HFFFF is important.

'

 From:  CALVIN FRENCH             Sent: 07-16-93 00:00
   To:  ALL                       Rcvd: -NO-
   Re:  (1/6) C-SMENU.BAS V1.1

Here's a neat-o-roonie pulldown menu routine that I'm sure SOMEBODY
will find good... nothing too spectacular, but useful anyways.

'C-SMENU1.BAS by Calvin French, 1993
'-------------------------------------------------------------
'This code is entirely PD but if you use it please put my name
'in your program somewhere however you don't have to if you
'don't want to
'-------------------------------------------------------------

DEFINT A-Z
'------ USED BY SUPERMENU
DECLARE SUB PullDownMenu (y1, TopX1(), BoxX1(), BoxX2(),_
 LastOpt(), MenuDat$(), Fore, Back, SelectFore, SelectBack,_
 hilightfore, hilightback, KeyFore, ReturnX, ReturnY)
DECLARE SUB DrawShadow (x1, y1, x2, y2)
'----------------------------
DECLARE SUB DrawScreen ()             '<-- these ARE NOT used by SuperMenu
DECLARE SUB DrawBox (x1, y1, x2, y2)  '<---'

CONST true = -1, false = 0

'To save space, I'll illustrate how the menu is set up, and then
'just read the rest of the menu data from DATA statments, ok?

REDIM MenuDat$(5, 7)
'
' First element (8): This is the total number of headers that the
'                    menu has
' Second element (7): This is the highest number of options, including
'                    separator lines, that your menu has
'
MenuDat$(1, 0) = " File "
'
' The 0th second element of each array is the header.
'
MenuDat$(1, 1) = " ^New Program"
'
' The carat (^) is used to illustrate a hotkey.
' NOTE: YOU MUST SPECIFY ONE HOTKEY PER MENU OPTION!
'
MenuDat$(1, 2) = " ^Open Program"
MenuDat$(1, 3) = " Save ^As"
MenuDat$(1, 4) = "^:"
'
' The "^:" means put a line separator in there.
'
MenuDat$(1, 5) = " ^Print"
MenuDat$(1, 6) = "^:"
MenuDat$(1, 7) = " E^xit"
TopX1(1) = 3
'
' This is the X location where the header (e.g., " File ") is to appear

'
BoxX1(1) = 2
'
' This is the X location where the left hand side of the box is to be
'
BoxX2(1) = 20
'
' This is the X location where the right hand side of the box is to be
'
LastOpt(1) = 7
'
' This is the number of options in the particular menu
'

'Now, to save space, I'll just read the rest of them...
FOR n = 2 TO 5
  READ LastOpt(n)
  READ TopX1(n)
  READ BoxX1(n)
  READ BoxX2(n)
  FOR x = 0 TO LastOpt(n)
    READ MenuDat$(n, x)
  NEXT x
NEXT n
'--------------------------------
'Effiecient way of doing toggles:
DIM ToggleChar$(-1 TO 0)      'true false
ToggleChar$(-1) = CHR$(254)
ToggleChar$(0) = " "

Toggle1 = false       'off

Fore = 0              'color for menu
Back = 7
SelectFore = 15       'color for topic bar. QB uses 7, 0 but i like 15, 1
SelectBack = 1
hilightfore = 7       'color for menu bar inside menu
hilightback = 0
KeyFore = 15          'hilight color for hotkeys

y1 = 1                'the Y loc you want the menu to appear on

COLOR 15, 1
PRINT STRING$(2000, 176);

DrawScreen

DO

  MenuDat$(4, 4) = ToggleChar$(Toggle1) + "^Toggle 1"

  PullDownMenu 1, TopX1(), BoxX1(), BoxX2(), LastOpt(),_
 MenuDat$(), Fore, Back, SelectFore, SelectBack, hilightfore,_
 hilightback, KeyFore, ReturnX, ReturnY
  'ReturnX is the returned X value
  'ReturnY is the returned Y value
  '
  'If you set it up to reroute ReturnX/ReturnY, you will be able to keep
  'the menu bar on the option the user last selected... nice...

  IF ReturnX = 4 AND ReturnY = 4 THEN Toggle1 = NOT Toggle1

LOOP UNTIL ReturnX = 1 AND ReturnY = 7

COLOR 7, 0
CLS
PRINT "Calvin French, 1993"
PRINT "Seeya!"

END


'Menu data. I did it like this to save space. You don't have to do it like
' this (read it into the array)
PulldownMenuData:
DATA 3,9,8,32," Edit "," Cu^t         Shift+DEL"," ^Copy         Ctrl+INS"," ^Paste       Shift+INS"
DATA 3,15,14,39," View "," ^SUBs...            F2"," O^utput Screen      F4"," Included ^Lines"
DATA 4,21,20,48," Search "," ^Find..."," ^Change...","^:","^Toggle 1"
DATA 4,72,51,78," Help "," ^Index"," ^Contents"," ^Topic:                F1"," ^Help on Help    Shift+F1"

SUB DrawBox (x1, y1, x2, y2)

LOCATE y1, x1
PRINT CHR$(218); STRING$(x2 - x1 - 2, 196); CHR$(191);

FOR n = y1 + 1 TO y2 - 1
  LOCATE n, x1
  PRINT CHR$(179); SPACE$(x2 - x1 - 2); CHR$(179);
NEXT n

LOCATE y2, x1
PRINT CHR$(192); STRING$(x2 - x1 - 2, 196); CHR$(217);


DrawShadow x1, y1, x2, y2

END SUB

SUB DrawScreen

COLOR 15, 0
DrawBox 9, 6, 70, 19

COLOR 15, 0
LOCATE 7, 10
PRINT " C-SMENU1.1, By Calvin French, May (sometime) 1993         "
COLOR 14
LOCATE 8, 10
PRINT "-----------------------------------------------------------"
COLOR 13
LOCATE 9, 10
PRINT " This is a small and power packed versitile pulldown menu  "
LOCATE 10, 10
PRINT " routine I put together awhile ago. I've added shadows in  "
LOCATE 11, 10
PRINT " This version, 1.1. 1.0 diddn't have shadows. Okay if you  "
LOCATE 12, 10
PRINT " want to use these routines, you may, but please put my    "
LOCATE 13, 10
PRINT " name on it below your copyright or something. It's a very "
LOCATE 14, 10
PRINT " fast routine, and lacks only the ALT+Letter routine to    "
LOCATE 15, 10
PRINT " access the menus, which is your job. It is all-QB, so you "
LOCATE 16, 10
PRINT " who don't like to use add-on libs should like this one!   "
COLOR 14
LOCATE 17, 10
PRINT " Have fun,                                                 "
COLOR 15
LOCATE 18, 10
PRINT " - Calvin -                                                "

END SUB

SUB DrawShadow (x1, y1, x2, y2)

DEF SEG = &HB800

YMem = y2 * 160
XMem = (x2 * 2) + 1

COLOR 8, 0

FOR n = x1 + 2 TO x2 + 1
  MemLoc = YMem + n * 2 - 1
  POKE MemLoc, 8
NEXT n

FOR n = y1 + 1 TO y2 + 1
  MemLoc = ((n - 1) * 160) + XMem - 2
  POKE MemLoc, 8
  POKE MemLoc + 2, 8
NEXT n

DEF SEG

END SUB

SUB PullDownMenu (y1, TopX1(), BoxX1(), BoxX2(), LastOpt(),_
 MenuDat$(), Fore, Back, SelectFore, SelectBack, hilightfore,_
 hilightback, KeyFore, ReturnX, ReturnY)

DIM CurrY(UBOUND(MenuDat$, 1))

OldX = 1
CurrX = 1
PulledDown = false


DIM HotKey(UBOUND(MenuDat$, 1), UBOUND(MenuDat$, 2))
DIM leftside$(UBOUND(MenuDat$, 1), UBOUND(MenuDat$, 2))
DIM rightside$(UBOUND(MenuDat$, 1), UBOUND(MenuDat$, 2))

COLOR Fore, Back
LOCATE y1, 1
PRINT SPACE$(80);

GOSUB PrintTopBar
GOSUB SaveScreen2

FOR x = 1 TO UBOUND(MenuDat$, 1)
  FOR y = 1 TO LastOpt(x)
    HotKeyLoc = INSTR(MenuDat$(x, y), "^")
    leftside$(x, y) = MID$(MenuDat$(x, y), 1, HotKeyLoc - 1)
    HotKey(x, y) = ASC(MID$(MenuDat$(x, y), HotKeyLoc + 1))
    rightside$(x, y) = MID$(MenuDat$(x, y), HotKeyLoc + 2)
  NEXT y
NEXT x

IF ReturnX > 0 OR ReturnY > 0 THEN
  FOR n = 1 TO UBOUND(MenuDat$, 1)
    CurrY(n) = 1
  NEXT n
  CurrX = ReturnX
  CurrY(CurrX) = ReturnY
  PulledDown = true
  GOSUB PrintCurrentMenu
END IF

GOSUB PrintCurrentTop

DO

  GOSUB PrintMenu

  DO
    key$ = INKEY$
  LOOP UNTIL LEN(key$)

  KeyCode = ASC(RIGHT$(key$, 1))

  SELECT CASE KeyCode
    CASE 75               'left
      CurrX = CurrX - 1
      IF CurrX < 1 THEN CurrX = UBOUND(MenuDat$, 1)
    CASE 77               'right
      CurrX = CurrX + 1
      IF CurrX > UBOUND(MenuDat$, 1) THEN CurrX = 1
    CASE 72               'up
      IF PulledDown = true THEN
        CurrY(CurrX) = CurrY(CurrX) - 1
        IF MenuDat$(CurrX, CurrY(CurrX)) = "^:" THEN CurrY(CurrX) = CurrY(CurrX) - 1
        IF CurrY(CurrX) < 1 THEN CurrY(CurrX) = LastOpt(CurrX)
        GOSUB PrintCurrentMenu
      END IF
    CASE 80               'down
      IF PulledDown = false THEN
        FOR n = 1 TO UBOUND(MenuDat$, 1)
          CurrY(n) = 1
        NEXT n
        PulledDown = true
      ELSE
        CurrY(CurrX) = CurrY(CurrX) + 1
        IF CurrY(CurrX) > LastOpt(CurrX) THEN CurrY(CurrX) = 1
        IF MenuDat$(CurrX, CurrY(CurrX)) = "^:" THEN CurrY(CurrX) = CurrY(CurrX) + 1
        IF CurrY(CurrX) > LastOpt(CurrX) THEN CurrY(CurrX) = 1
      END IF
      GOSUB PrintCurrentMenu
    CASE 13
      IF PulledDown = true THEN
        GOSUB RestoreScreen2
        ReturnX = CurrX
        ReturnY = CurrY(CurrX)
        EXIT SUB
      ELSE
        PulledDown = true
        FOR n = 1 TO UBOUND(MenuDat$, 1)
          CurrY(n) = 1
        NEXT n
        GOSUB PrintCurrentMenu
      END IF
    CASE ELSE

      KeyCode = KeyCode OR 32
      Search = HotKey(CurrX, CurrY(CurrX)) OR 32
      found = false

      FOR n = CurrY(CurrX) + 1 TO LastOpt(CurrX)
        Search = HotKey(CurrX, n) OR 32
        IF Search = KeyCode THEN
          CurrY(CurrX) = n
          found = true

          EXIT FOR
        END IF
      NEXT

      FOR n = 1 TO CurrY(CurrX)
        Search = HotKey(CurrX, n) OR 32
        IF Search = KeyCode THEN
          IF found = false THEN
            CurrY(CurrX) = n
            found = true
          END IF
          EXIT FOR
        END IF
      NEXT n

      IF found = true THEN
        GOSUB PrintCurrentMenu
        ReturnX = CurrX
        ReturnY = CurrY(CurrX)
        GOSUB RestoreScreen2
        EXIT SUB
      END IF

  END SELECT


LOOP

EXIT SUB

PrintTopBar:
FOR n = 1 TO UBOUND(MenuDat$, 1)
  LOCATE y1, TopX1(n)
  PRINT MenuDat$(n, 0);
NEXT n
RETURN

PrintCurrentTop:
LOCATE y1, TopX1(CurrX)
COLOR SelectFore, SelectBack
PRINT MenuDat$(CurrX, 0);
RETURN

SaveScreen2:
PCOPY 0, 2    'PCOPY is very fast, and well suited for this task
RETURN

RestoreScreen2:
PCOPY 2, 0    'PCOPY is very fast, and well suited for this task
RETURN

PrintMenu:
IF CurrX <> OldX THEN
  GOSUB RestoreScreen2
  GOSUB PrintCurrentTop
  IF PulledDown = true THEN
    GOSUB PrintCurrentMenu
  END IF
END IF

OldX = CurrX

RETURN

PrintCurrentMenu:

COLOR Fore, Back
LOCATE y1 + 1, BoxX1(CurrX)

PRINT CHR$(218); STRING$(BoxX2(CurrX) - BoxX1(CurrX) - 1, CHR$(196)); CHR$(191)

FOR n = 1 TO LastOpt(CurrX)
  LOCATE y1 + n + 1, BoxX1(CurrX)
  PRINT CHR$(179);
  IF MenuDat$(CurrX, n) <> "^:" THEN
    IF n <> CurrY(CurrX) THEN
      COLOR Fore, Back
      PRINT leftside$(CurrX, n);
      COLOR KeyFore, Back
      PRINT CHR$(HotKey(CurrX, n));
      COLOR Fore, Back
      PRINT rightside$(CurrX, n);
      PRINT SPACE$(BoxX2(CurrX) - BoxX1(CurrX) - LEN(MenuDat$(CurrX, n)));
    ELSE
      COLOR hilightfore, hilightback
      PRINT leftside$(CurrX, n);
      COLOR KeyFore, hilightback
      PRINT CHR$(HotKey(CurrX, n));
      COLOR hilightfore, hilightback
      PRINT rightside$(CurrX, n);
      PRINT SPACE$(BoxX2(CurrX) - BoxX1(CurrX) - LEN(MenuDat$(CurrX, n)));
    END IF
    COLOR Fore, Back
    PRINT CHR$(179);
  ELSE
    COLOR Fore, Back
    LOCATE y1 + n + 1, BoxX1(CurrX)
    PRINT CHR$(195); STRING$(BoxX2(CurrX) - BoxX1(CurrX) - 1, CHR$(196)); CHR$(180);
  END IF
NEXT n

LOCATE y1 + LastOpt(CurrX) + 2, BoxX1(CurrX)
PRINT CHR$(192); STRING$(BoxX2(CurrX) - BoxX1(CurrX) - 1, CHR$(196)); CHR$(217)

DrawShadow BoxX1(CurrX), y1 + 1, BoxX2(CurrX) + 1, LastOpt(CurrX) + 3

RETURN

END SUB

'

' From:  IAN REMMLER               Sent: 07-17-93 21:57
'   To:  ALL                       Rcvd: -NO-
'   Re:  3D STRANGE ATTRACTOR DEMO
'
'Hey everybody!
'Here's a 3D attractor demo that lets you rotate the attractor on
'the X, Y, and Z axes then view it. (like on FractInt) If you have
'a mouse you can use it to zoom in. I didn't spend time on putting
'in a keyboard equivalent, so if you don't have a mouse you can make
'a routine for the keyboard, or change the WINDOW statement manually.
'Have fun with it, and feel free to hack it to pieces.

DECLARE SUB Crsr (x!)
DECLARE SUB zoom ()
DECLARE FUNCTION MPos (Coord)
DECLARE FUNCTION MBttn ()

'$INCLUDE: 'qb.bi'
DIM SHARED Regs AS RegTypeX
DIM sine(359) AS SINGLE, cosine(359) AS SINGLE

CONST pi = 3.1415926535#

dist = 100 'This is the distance from the screen used in the
 'perspective formula.

AngleX = 0 '\
AngleY = 0 ' > angles of rotation
AngleZ = 0 '/

SCREEN 9
PRINT "Creating SIN/COS Tables..."
PRINT : PRINT "Press F1 any time to goto Main Menu."
PRINT "Press F2 any time to exit program."
PRINT : PRINT "If you have a mouse, you can use the LMB to"
PRINT "zoom in on an attractor,or the RMB to exit."
LOCATE 24, 1: PRINT "Strange Attractor Demo - By: Ian Remmler.";
twirl$ = "\-/" + CHR$(179)

FOR t = 0 TO 359 'create sine/cosine tables
LOCATE 1, 28: PRINT MID$(twirl$, t MOD 4 + 1, 1)
sine(t) = SIN(t * (pi / 180))
cosine(t) = COS(t * (pi / 180))
NEXT

KEY(1) ON            '\
KEY(2) ON            ' \ sets up event trapping on F1 & F2
ON KEY(1) GOSUB Main ' /
ON KEY(2) GOSUB Leave'/
GOSUB WhichOne

Lorenz: 'Converted from the FractInt documentation.
WINDOW (-32, -0)-(32, 35)
dt = .05
a = 3
b = 15
c = 1

Lstart:
x = 1
y = 1
z = 1

CLS
GOSUB Translate
PSET (xxx, yyy)
Crsr 1
DO
xx = x: yy = y: zz = z
x = xx + (-a * xx * dt) + (a * yy * dt)
y = yy + (b * xx * dt) - (yy * dt) - (zz * xx * dt)
z = zz + (-c * zz * dt) + (xx * yy * dt)
GOSUB Translate
Crsr 0: LINE -(xxx, yyy): Crsr 1
IF MBttn = 1 THEN zoom: GOTO Lstart
LOOP UNTIL MBttn = 2
Crsr 0
GOSUB Leave

Rossler: 'Also from FractInt docs.
WINDOW (-64, -35)-(64, 35)
dt = .05
a = .2
b = .2
c = 5.7

Rstart:
x = 1
y = 1
z = 1

CLS
GOSUB Translate
PSET (xxx, yyy)
Crsr 1
DO
xx = x: yy = y: zz = z
x = xx - yy * dt - zz * dt
y = yy + xx * dt + a * yy * dt
z = zz + b * dt + xx * zz * dt - c * zz * dt
GOSUB Translate
Crsr 0: LINE -(xxx, yyy): Crsr 1
IF MBttn = 1 THEN zoom: GOTO Rstart
LOOP UNTIL MBttn = 2
Crsr 0
GOSUB Leave

Mutant: 'Wrote this one all by myself! Pretty spiffy, huh?
WINDOW (-32, -17.5)-(32, 17.5)
dt = .02
a = 8
b = 10
c = 10

Mstart:
x = 1
y = 1
z = 1

CLS
GOSUB Translate
PSET (xxx, yyy)
Crsr 1
DO
xx = x: yy = y: zz = z
x = xx - (a * zz * dt) + (-a * yy * dt)
y = yy + (b * xx * dt) - (yy * dt) - (zz * xx * dt)
z = zz + (-c * zz * dt) - (xx * yy * dt)
GOSUB Translate
Crsr 0: LINE -(xxx, yyy): Crsr 1
IF MBttn = 1 THEN zoom: GOTO Mstart
LOOP UNTIL MBttn = 2
Crsr 0
GOSUB Leave

Translate: 'converts x,y,z coords. to x,y so they can be put on
 'the screen. We use the basic rotation formula on the
 'X axis, then Y, then Z.
za = z * sine(AngleX) - y * cosine(AngleX) '\ X rotation
ya = z * cosine(AngleX) + y * sine(AngleX) '/
za = za * sine(AngleY) - x * cosine(AngleY) '\ Y rotation
xa = za * cosine(AngleY) + x * sine(AngleY) '/
xa = ya * sine(AngleZ) - xa * cosine(AngleZ) '\ Z rotation
ya = ya * cosine(AngleZ) + xa * sine(AngleZ) '/
xxx = xa * (dist / (dist + za))
yyy = ya * (dist / (dist + za))
RETURN

Main:
KEY(1) ON
ON KEY(1) GOSUB Main
CLS : PRINT "Main Menu!"
PRINT "1. Select an Attractor."
PRINT "2. Change Parameters."
PRINT "3. Change Angles of Rotation."
PRINT
DO: q = VAL(INKEY$)
LOOP WHILE q = 0
ON q GOSUB WhichOne, Params, Angles
CLS
RETURN

WhichOne:

CLS : PRINT "Select an Attractor!"
PRINT : PRINT "1. Lorenz"
PRINT "2. Rossler"
PRINT "3. Mutant"
PRINT
DO: q = VAL(INKEY$)
LOOP WHILE q = 0
ON q GOSUB Lorenz, Rossler, Mutant

Params:
PRINT "Input New Parameters!"
PRINT
PRINT "A= "; a; " "; : INPUT a
PRINT "B= "; b; " "; : INPUT b
PRINT "C= "; c; " "; : INPUT c
PRINT "DT= "; dt; " "; : INPUT dt
CLS
RETURN

Angles:
PRINT "Change Angles of Rotation!"
PRINT
PRINT "X= "; AngleX; " "; : INPUT AngleX
PRINT "Y= "; AngleY; " "; : INPUT AngleY
PRINT "Z= "; AngleZ; " "; : INPUT AngleZ
PRINT "Perspective Distance= "; dist; " "; : INPUT dist
CLS
RETURN

Leave:
END

SUB Crsr (x) 'this sub turns the pointer on and off (Crsr 0=off)
SELECT CASE x                                     '(Crsr 1=on)
CASE 0
Regs.ax = 2
CASE 1
Regs.ax = 1
END SELECT
CALL INTERRUPTX(&H33, Regs, Regs)
END SUB

FUNCTION MBttn 'returns which buttons are currently down.
Regs.ax = 3
CALL INTERRUPTX(&H33, Regs, Regs)
MBttn = Regs.bx
END FUNCTION

FUNCTION MPos (Coord) 'returns the x,y coords. of the mouse
Regs.ax = 3
CALL INTERRUPTX(&H33, Regs, Regs)
SELECT CASE Coord
CASE 0
MPos = Regs.cx
CASE 1
MPos = Regs.dx
END SELECT
END FUNCTION

SUB zoom 'zooms in on the attractor using the mouse.
Crsr 0
PCOPY 0, 1
Crsr 1
x1 = PMAP(MPos(0), 2)
y1 = PMAP(MPos(1), 3)
DO
Crsr 0
PCOPY 1, 0
x2 = PMAP(MPos(0), 2)
y2 = PMAP(MPos(1), 3)
Crsr 1
LINE (x1, y1)-(x2, y2), , B
WHILE PMAP(MPos(0), 2) = x2 AND PMAP(MPos(1), 3) = y2: WEND
LOOP WHILE MBttn = 1
WINDOW (x1, y1)-(x2, y2)
Crsr 0
END SUB


'



 From:  MARK BUTLER               Sent: 07-16-93 20:32
   To:  ALL                       Rcvd: -NO-
   Re:  QWINDOWS  1/4

 Hello ALL, a couple years ago I posted a collection of QB windowing
 routines. Many folks have come and gone from this conference since
 then so I thought maybe I'd post them again for those who never saw
 them. For those well familiar with these routines a new one has been
 added -"UnScroll" which is a variation of the "Expand" routine that
 expands to it's full height vertically before it begins to expand
 horizontally.
==========================8< Cut Here 8<=============================
 ' Shadowed window routines by Mark H Butler placed into the public domain
 ' on February 28, 1992 and revised July 16 1993. I would appreciate any
 ' feedback on these routines and if you improve on them I'd kinda like to
 ' know what you did so I can benefit by the improvements to.  If that's a
 ' deal then enjoy the routines, gratis =MHB=

 DEFINT A-Z
 DECLARE SUB Drawbox (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB Shadow (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB Explode (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB Expand (UpRow%, LtCol%, LoRow%, RtCol%)
 ' UnScroll is the routine that is new to this collection.
 DECLARE SUB UnScroll (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB ScreenClear (LineColor%)
 DECLARE SUB Pause (ticks%)

 ' These first lines of code are included to demo the
 ' Exploding, expanding and unscrolling window routines.
 ' We'll fill the sceen with a bunch of crap so our windows
 ' will have a backdrop you can see their Shadows against.

    LOCATE , , 0
    COLOR 14, 1
    CLS
    FOR I = 1 TO 13
        FOR ch = 33 TO 178
            PRINT CHR$(ch);
        NEXT ch
    NEXT I

    COLOR 4, 7
    Explode 5, 15, 15, 65

    COLOR 0
    LOCATE 9, 27
    PRINT "This 'Exploding' window was"
    LOCATE 10, 25
    PRINT "written entirely in QuickBASIC! "
    LOCATE 12, 21
    PRINT "(press any key for the 'Expand' routine)"
    SLEEP

    COLOR 0, 3
    Expand 2, 5, 22, 75

    COLOR 4
    LOCATE 8, 12
    PRINT "This is the 'Expand' routine. Like 'Explode' it calls"
    LOCATE 9, 12
    PRINT "the 'Drawbox' routine. It expands to it's full horizontal"
    LOCATE 10, 12
    PRINT "width  *before*  it begins to expand vertically though."
    LOCATE 13, 12
    PRINT "(press any key for the 'UnScroll' routine)"
    SLEEP

    COLOR 0, 7
    UnScroll 2, 3, 23, 78
    LOCATE 8, 12
    PRINT "This is the 'UnScroll' routine. Like 'Expand' it calls"
    LOCATE 9, 12
    PRINT "the 'Drawbox' routine. It expands to it's full vertical"
    LOCATE 10, 12
    PRINT "height  *before*  it begins to expand horizontally though."
    LOCATE 13, 12
    PRINT "(press any key for some quasi-fancy screen clearing)"

    SLEEP

    ScreenClear 3

 '+++++++++++++++++++++ windowing subs begin here ++++++++++++++++++++++

 ' This routine draws a double line box to the dimensions set
 ' in UpRow%, LtCol%, LoRow% and RtCol%. If you want a single line box
 ' just change the ascii chars, e.g. change CHR$(205) to CHR$(196) etc.

 SUB Drawbox (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    Wide% = (RtCol% - LtCol%) - 1
    LOCATE UpRow%, LtCol%
    PRINT CHR$(201); STRING$(Wide%, CHR$(205)); CHR$(187);
    FOR I% = UpRow% + 1 TO LoRow% - 1
        LOCATE I%, LtCol%
        PRINT CHR$(186); SPACE$(Wide%); CHR$(186);
    NEXT I%
    LOCATE LoRow%, LtCol%
    PRINT CHR$(200); STRING$(Wide%, CHR$(205)); CHR$(188);
 END SUB

 ' This routine will "expand" the window onto the screen calling on
 ' DRAWBOX to draw sucessively wider boxes until it hits the width
 ' dimensions. Then it will expand to meet the vertical dimensions.
 '
 SUB Expand (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    RowCenter% = ((LoRow% - UpRow%) / 2) + UpRow%
    ColCenter% = ((RtCol% - LtCol%) / 2) + LtCol%
    UprRow% = RowCenter%: LeftCol% = ColCenter%
    LwrRow% = RowCenter%: RghtCol% = ColCenter%
    DO
        LeftCol% = LeftCol% - 1
        RghtCol% = RghtCol% + 1
        IF LeftCol% < LtCol% THEN LeftCol% = LtCol%
        IF RghtCol% > RtCol% THEN RghtCol% = RtCol%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF LeftCol% = LtCol% AND RghtCol% = RtCol% THEN EXIT DO
    LOOP
    DO
        UprRow% = UprRow% - 1
        LwrRow% = LwrRow% + 1
        IF UprRow% < UpRow% THEN UprRow% = UpRow%
        IF LwrRow% >= LoRow% THEN LwrRow% = LoRow%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF UprRow% = UpRow% AND LwrRow% = LoRow% THEN EXIT DO
        Pause 1
    LOOP
    Shadow UpRow%, LtCol%, LoRow%, RtCol%
 END SUB

 ' This routine will "Explode" the window onto the screen calling on
 ' DRAWBOX to draw sucessively larger boxes until it hits the limits
 ' set in UpRow%, LtCol%, LoRow% and RtCol%. The first few lines determine
 ' where the approximate center of the box begins even if the window is
 ' to be located off-center with respect to the screen.
 '
 SUB Explode (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    RowCenter% = ((LoRow% - UpRow%) / 2) + UpRow%
    ColCenter% = ((RtCol% - LtCol%) / 2) + LtCol%
    UprRow% = RowCenter%: LeftCol% = ColCenter%
    LwrRow% = RowCenter%: RghtCol% = ColCenter%
    DO
        UprRow% = UprRow% - 1
        LeftCol% = LeftCol% - 3
        LwrRow% = LwrRow% + 1
        RghtCol% = RghtCol% + 3
        IF UprRow% < UpRow% THEN UprRow% = UpRow%
        IF LeftCol% < LtCol% THEN LeftCol% = LtCol%
        IF LwrRow% > LoRow% THEN LwrRow% = LoRow%
        IF RghtCol% > RtCol% THEN RghtCol% = RtCol%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF UprRow% = UpRow% AND LeftCol% = LtCol% THEN
            IF LwrRow% = LoRow% AND RghtCol% = RtCol% THEN
                EXIT DO
            END IF
        END IF
        Pause 1
    LOOP
    Shadow UpRow%, LtCol%, LoRow%, RtCol%   '*** now give it a Shadow ****
 END SUB

 '*** Just a little pauser that some of the routines
 '*** need so that they do not execute way too fast.
 SUB Pause (ticks%)
    DEF SEG = 0
    DO UNTIL TestTick% > ticks%
        IF LEN(INKEY$) THEN EXIT SUB
        LastTick% = GetTick%
        GetTick% = PEEK(&H46C)
        IF LastTick% <> GetTick% THEN
            TestTick% = TestTick% + 1
        END IF
    LOOP


    DEF SEG
 END SUB

 'This routine will do a little fancy screen clearing by simulating
 'an old style 1950s TV set being shut off. Screen shrinks to a single
 'horizontal line then disappears to a shrinking dot and is gone.
 'I wrote it for 80x25 text mode so if your displaying more screen lines
 'than 25 you'll have to play with it to get it to erase them all.
 '
 SUB ScreenClear (LineColor%) STATIC
    LOCATE , , 0
    DIM Lines$(1 TO 23)
    Lines$(1) = STRING$(80, CHR$(196))
    Sp% = 2
    Length% = 76
    FOR I% = 2 TO 21
        Lines$(I%) = SPACE$(Sp%) + STRING$(Length%, CHR$(196)) + "  "
        Sp% = Sp% + 2
        Length% = Length% - 4
    NEXT I%
    Lines$(22) = SPACE$(39) + CHR$(179) + SPACE$(2)
    Lines$(23) = SPACE$(39) + "." + SPACE$(2)
    COLOR 0, 0
    x% = 1
    y% = 25
    FOR I% = 1 TO 12
        LOCATE y%, 1
        PRINT STRING$(80, CHR$(32));
        LOCATE x%, 1
        PRINT STRING$(80, CHR$(32));
        Pause 1
        x% = x% + 1
        y% = y% - 1
    NEXT I%
    COLOR LineColor%, 0
    FOR I% = 1 TO 23
        LOCATE 13, 1
        PRINT Lines$(I%);
        Pause 1
    NEXT I%
    COLOR 7
    LOCATE , , 1, 6, 7
    CLS
 END SUB

 ' This routine creates a transparent Shadow along the right side
 ' and bottom edge of the box. Note: Special thanks to John Strong
 ' for his very helpful tips on what to POKE and where.
 '
 SUB Shadow (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    DEF SEG = &H40
    mono% = PEEK(&H10)
    IF (mono% AND 48) = 48 THEN
        EXIT SUB            '*** Forget the Shadow if it's monochrome.
    ELSE
        DEF SEG = &HB800
    END IF

 '****** find out what the screen attributes already are ****

    attr% = SCREEN(LoRow% + 1, RtCol% + 1, -1)  ' Get the attribute.
    attr% = attr% AND 15                     ' Calculate forground.
    attr% = attr% - 8                        ' Remove bright.
    IF attr% < 1 THEN attr% = 8              ' In case color wasn't bright.

 '****** use the given box dimensions to POKE a ***********
 '****** Shadow on the right side and bottom edge *********

    FOR row% = UpRow% + 1 TO LoRow% + 1       '***** right edge locations.
        FOR Col% = RtCol% + 1 TO RtCol% + 2   '***** make it 2 chars Wide.
            offset% = (row% - 1) * 160 + (Col% - 1) * 2 + 1
            POKE offset%, attr%
        NEXT
    NEXT
    row% = LoRow% + 1                        '***** now POKE along the
    FOR Col% = LtCol% + 2 TO RtCol% + 2      '***** bottom edge
        offset% = (row% - 1) * 160 + (Col% - 1) * 2 + 1
        POKE offset%, attr%
    NEXT
    DEF SEG
 END SUB

 ' This routine will "unscroll" the window onto the screen calling
 ' on DRAWBOX to draw sucessively taller boxes until it hits the height
 ' dimension. Then it will expand to meet the horizontal dimensions.
 '
 SUB UnScroll (UpRow%, LtCol%, LoRow%, RtCol%)
    RowCenter% = ((LoRow% - UpRow%) \ 2) + UpRow%
    ColCenter% = ((RtCol% - LtCol%) \ 2) + LtCol%
    UprRow% = RowCenter%: LeftCol% = ColCenter%
    LwrRow% = RowCenter%: RghtCol% = ColCenter%
    DO
        UprRow% = UprRow% - 1
        LwrRow% = LwrRow% + 1
        IF UprRow% < UpRow% THEN UprRow% = UpRow%
        IF LwrRow% >= LoRow% THEN LwrRow% = LoRow%
        Drawbox UprRow%, LeftCol% - 1, LwrRow%, RghtCol% + 1
        IF UprRow% = UpRow% AND LwrRow% = LoRow% THEN EXIT DO
    LOOP
    DO
        LeftCol% = LeftCol% - 1
        RghtCol% = RghtCol% + 1
        IF LeftCol% < LtCol% THEN LeftCol% = LtCol%
        IF RghtCol% > RtCol% THEN RghtCol% = RtCol%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF LeftCol% = LtCol% AND RghtCol% = RtCol% THEN EXIT DO
    LOOP

    Shadow UpRow%, LtCol%, LoRow%, RtCol%

 END SUB

'

 From:  EVANS MARTIN              Sent: 07-18-93 16:45
   To:  ALL                       Rcvd: -NO-
   Re:  CREDIT CARD NUMBER VALIDA

This is a complete working credit card number validation program.
This program does NOT validate available credit or even if the card
is active.  All it does is run a checksum on the number to determine
if it could be a valid credit card number.  Also, it determines
what type of card it is.  Have fun with the PD example.

'** Save this script to a file, edit out all of the non-QB related
'** text and execute it in a QB environment to retrieve CARDCHK.BAS
CLS:?STRING$(50,177):?"Creating: CARDCHK.BAS with PostIt! v2.9f"
DEFINT A-Z:FOR A=0 TO 6:P(A)=2^A:NEXT:OPEN "B",1,"CARDCHK.BAS"
T$="abcdefghijklmnopqrstuvwxyz":T$=T$+UCASE$(T$)+"0123456789()"
G"dX0unOqsobvvubIiqXwzHnxzGuMB0vMCGmMCLrwA0bYyHjhzG4wDTjwzY5ciGOd
G"iIWcidjxzKLgDdfMCKrsdkaciwfgBPr2qHjhzLaspGadiNasqZnxDTvgiPrhiPn
G"hiU9gDGegi2fgBPrgiJfMCK5sdkacibrci9actujvsnrcksrLuj1ejOmKCLrwA0
G"nuyYrgjPKciGCcisvwBVzxzGWwzHr2l0jxyPXgiIXwyUT2CU0GcGassgbsqKasp
G"GiIiGqfsf5eif5erGaciGaYjGq2BUDcDGi2B0HwzYbcDVbYyOv2yRbsAMbIB1Xg
G"BnOaiGm0u11wjG0diWaciGaciGaciGaciGaciGaciGaciGaYjGmfDHjhDGCxA0H
G"giWaIzVjhiJHwzJTgiZvxBU0GcGast1XgDPbhBPvMCG0diY0GcGaYjGaLCVnwzZ
G"nhiMj3BTbICPDgA0bcDVbcBLzgDU0GcGaIrpjfiPbspGWuroHsqKKciTasmGq1t
G"GeditrvrqbslXaciNasqSXgiKL2zPr3CGugEJvgC0bcBHnhDG8MBL5sdkaciGas
G"qG0dibn1qO0userckbrclGKglGetkPaslGqdoGaciGCcihvgDGegiZLMBNXwzGq
G"wANLgDU0GcGaciGmvrmv0qubYqbnvrGeudkaciGaYqbnvrGK0uG0diZ0GcGaciG
G"aciGacicfMBRnuyYrgjG0diIeuBLjxAJfMBGueEWjxzZnNinOaiGacidf0ufbss
G"tbspGqtdkaciGaciGaciGiuyUT2qHjhzKaspGiIvPnxyI0GcGaciGmuqtveijnf
G"i9asnnOaiGaciGaciGaIqH52AdfMCKrci9aIinf2C0vMCGmuyYrMinOaiGacidf
G"0ufbsrmnvrnOaiGaciGaciGaIqH52AdfMCKrci9aIiprhALjNinOaiGacif5erG
G"mvrmv0qu1GcGaciGKKrGeei8acmG8KuGeei(asoGqfsf5eiGaciGaciGaciNass
G"MbIBVrhiW0soS0GcGaciGaciGmett1GcGaciGaciGiurfbvdkaciGaciGacusLK
G"tubIigfwASvNCLbsAUbIvHXwAKfgDLbYqYvgzPrhidfMCKbIuVvhDP5wzI0GcGa
G"ciGaciGaLuj5evGicuSvwyZvgiK9giU9gDGuMB0vMCGqwyZHwzZbYBYbYCWf2yL
G"nhiP5giJjxzKLgDGmwyYrgiUvxBIvMCGywALXgzHisdkaciGaciGaYqYvgzPr3q
G"HjhzKaspGiIinOaiGaciGacif5erGaciGaciGaciGaciGaciGaciGaciNaciGqh
G"AL5giNvgDG8wD05sdkaciGasroreijzudkaciGasqG0dibbIkG0uDSrxAWXwALj
G"xdkaciGast1XgDPbhBPvMCG0diZaslG0uDSrxAWXwALjhiGaciGCciu92zNXwzG
G"0wDSrxAWXwALjxdkaciGassgbsqG4di5acvivKtnOaiGaciGaciuvwBWrci9act
G"ujvsnrcktrLuKGsqPKciGaciGaYjGeezKbIB11MyLj3CGq3BNvgDOvMCU0GcGac
G"iGaciGeei9acmnOaiGaciGacig9KuGOei9asmGq1tGWuroHcvL1gCKKsdkaciGa
G"ciGaciGeei9asqGScibn1qO0userckuvwBWrclGOelGetkPaslGqdoNaIrHnhDL
G"jhi0HwyUbIvbXKlnOaiGaciGaciovewu1GcGaciGuKtebssg1GcGaciGm0u11wj
G"G0didnvDTvciRasqnOaiG4uryrvdkaciNaItVDhi3vgiZvNy0jxyJrhi0HwzGmg
G"ALn2AZvxBnOaiGCciMj3BTbcDOvgiUvgE0bcAPDgALjhiTvhB0LgCSvgiVzgiXa
G"JlnOaiGm0u11wjG0diOGYqtvxBLaYkGKtkGWfiXatkGOciXadiTaYqtvxBL0GcG
G"assgbIvbXeksL0rirfjOeejSasmPKci9aYqtvxBLacvivKtnOaiGaciGyvySLgz
G"dfMCKvci9aslX0GcGaciGacusLKtu1GcGaciGacusLKtubIidfMCKbciGaIoGic
G"iRasvdf0ufrckcfMBRnuyYrgjP0GcGaciGacusLKtubIibn2y0bItVbIoGiciRa
G"svdf0ufrckbrsknOaiGaciGaLuj5evGiYu0fgD1nhiGOdiIStdkaciGacid9etp
G"jfiXqdlGatdkaciGaciqjvsorfiIavyZnxzKbIDHXwAKfgDP9MBHisdkacifX0u
G"f1GcGaciGacusLKtu1GcGaciGaIqfveunOaiGaciGaLuj5evGiYqHjhzGaciGOd
G"ij5MDHXwAKbYqHjhzI0GcGaciGacusLKtubIibn2y0bItVbIoGiciRasvdf0ufr
G"ckbrsknOaiGaciGaLuj5evGiYu0fgD1nhiGOdiIStdkaciGacid9etpjfiYGdlG
G"atdkaciGaciqjvsorfiIyuyPXwzKbIDHXwAKfgDP9MBHisdkaciGacicfMBRnuy
G"YrgjG0diIisdkacif5erGKKrnOaiGm0tm9KuGCdlGatdk0Gc"
N=1926:K=255:IF LEN(C$)<>2568 THEN ?"Incomplete script file!":BEEP:END
FOR A=1 TO N:IF L=0 THEN GOSUB G:L=6:LOCATE 1:?STRING$((51&*A)\N,8)
W=T\P(6-L):GOSUB G:W=W OR T*P(L):L=L-2:B$=CHR$(W AND K):PUT 1,,B$:NEXT
?:IF C<>76 THEN ?"Bad checksum!":BEEP:END ELSE ?"Success!":END
G:I=I+1:T=INSTR(T$,MID$(C$,I,1))-1:C=(C+T)*2:C=C\256+(C AND 255):RETURN
SUB G(A$):SHARED C$:C$=C$+LEFT$(A$,63):END SUB
'

' From:  REUVEN LAX                Sent: 07-18-93 15:28
'   To:  VICTOR YIU                Rcvd: -NO-
'   Re:  SORTING
'
'I wrote a sort routine that is faster than any other I've seen.  Can
'you come up with anything faster?  (actually it uses the same Idea as A
'quickSort but this is not recursive).  Here it is!


DECLARE SUB MyQsort ()
'$DYNAMIC
DEFINT A-Z
DIM SHARED Array(1 TO 1), Start, Finish, Stack(1 TO 128)
FOR A = 1 TO 14
  Count = 2 ^ A
  Start = 1: Finish = Count
  REDIM Array(1 TO Count)
  RANDOMIZE TIMER
  FOR B = 1 TO Count
    Array(B) = RND * 32766 + 1
  NEXT

  T1! = TIMER
  MyQsort
   T2! = TIMER - T1!
  PRINT "MyQuickSort:  took"; T2!; "secs for"; Count; "numbers."
NEXT

REM $STATIC
SUB MyQsort
  sp = 0
DO
  IF Start - Finish = 1 THEN
    IF Array(Start) > Array(Finish) THEN SWAP Array(Start), Array(Finish)
  ELSE
  DO WHILE Start < Finish
      Top = Start: Bot = Finish
      Cmp = Array((Start + Finish) \ 2)
      DO
        DO WHILE Array(Top) < Cmp
          Top = Top + 1
        LOOP
        DO WHILE Cmp < Array(Bot)
          Bot = Bot - 1
        LOOP
        IF Bot >= Top THEN
          SWAP Array(Top), Array(Bot)
          Top = Top + 1: Bot = Bot - 1
        END IF
      LOOP UNTIL Top > Bot
      sp = sp + 1
      Stack(sp) = Finish
      Finish = Bot
    LOOP
  END IF
    Start = Top
    Finish = Stack(sp): sp = sp - 1
    LOOP WHILE sp > 0

END SUB
'

' From:  JIM LITTLE                Sent: 07-17-93 03:02
'   To:  ALL                       Rcvd: -NO-
'   Re:  ANIMAL
'
'Hi, All!
'
'The next 3 posts are an interesting example of "intelligence imitation"
'(as I call it) in a guessing game-like program. You think of an
'animal, and the computer attempts to guess it.  If you don't know the
'trick, it seems to be quite intelligent.  Then you pick one it doesn't
'know, and all becomes clear..
'
'The fourth post is a PostIt! script of a sample data file to go with
'the program.  You might want to try it with the data file, first, as
'that will give you a better idea of how it works.  Then, delete
'ANIMAL.DAT, and create your own, customized, artificially intelligent
'database of animals!  <grin>
'
'Have fun!  Jim

'ANIMAL.BAS

'by Jim Little

'This code is not copyrighted.  However, if you use this code without major
' modifications, please give me credit.

'This code implements an old "Intelligence Imitating" algorithm I first
' saw on the Apple II.  Undoubtably, the routine goes back farther than
' that.  I've never seen it on the IBM, though, and thought it may be of
' interest.

'This was thrown together at 3:00 AM.. please excuse the poor design.

'What does it do?  Run it and find out!

DECLARE SUB Intro ()
DECLARE SUB Main ()
DECLARE SUB GetChoice (choice%)
DECLARE SUB InitializeData ()

TYPE animal
   yes AS INTEGER
   no AS INTEGER
   animal AS STRING * 80
END TYPE

CONST cAssign = 1
CONST cRetrieve = 2

CONST False = 0
CONST True = NOT False

Intro
DO: k$ = INKEY$: LOOP UNTIL LEN(k$)
DO UNTIL k$ = CHR$(27)
   VIEW PRINT 5 TO 25
   Main
   VIEW PRINT 1 TO 25
   Intro
   DO: k$ = INKEY$: LOOP UNTIL LEN(k$)
LOOP

SUB GetChoice (choice%)
'gets a y/n response from the user and returns it as -1 (for y) or 0 (for n)

LOCATE , , 1

DO
   k$ = INKEY$
LOOP WHILE UCASE$(k$) <> "Y" AND UCASE$(k$) <> "N"
choice% = (UCASE$(k$) = "Y")
PRINT k$;

LOCATE , , 0

END SUB

SUB InitializeData
'initializes file #1 to include one question and two animals.

DIM animal AS animal    'the question/animals

animal.animal = "Does your animal swim a lot?"
animal.yes = 2
animal.no = 3
PUT #1, 1, animal

animal.animal = "goldfish"
animal.yes = -1
animal.no = -1
PUT #1, 2, animal

animal.animal = "cat"
animal.yes = -1
animal.no = -1
PUT #1, 3, animal

END SUB

SUB Intro

CLS
PRINT TAB(37); "Animal"
PRINT TAB(34); "by Jim Little"
PRINT
PRINT
PRINT "Think of an animal, and I will attempt to guess it.  As you play, I will"
PRINT "learn more animals.  Eventually, I will know every common animal."
PRINT
PRINT "Press any key when you've thought of an animal, or ESC to quit."

END SUB

SUB Main
'This is the main program driver.

DIM animalnum&       'animal/question being checked/asked
DIM animal AS animal
DIM usersanimal$     'the user's animal/question
DIM companimal$      'the computer's animal/question
DIM newanimal AS animal  'new animal being added to data
DIM choice%          'yes or no response from user (yes is -1,  no is 0)
DIM records&         'number of records in ANIMAL.DAT

OPEN "ANIMAL.DAT" FOR RANDOM AS #1 LEN = LEN(animal)
IF LOF(1) = 0 THEN
   InitializeData
END IF

CLS
animalnum& = 1
GET #1, animalnum&, animal
companimal$ = RTRIM$(animal.animal$)
DO
   IF animal.yes <> -1 THEN 'question, not animal
      PRINT companimal$; " ";
      GetChoice choice%
      PRINT : PRINT
      IF choice% THEN  'choice = 'YES'
         animalnum& = animal.yes
      ELSE  'choice = 'NO'
         animalnum& = animal.no
      END IF
   END IF
   GET #1, animalnum&, animal
   companimal$ = RTRIM$(animal.animal$)
LOOP UNTIL animal.yes = -1

PRINT "Is your animal a "; companimal$; "? ";
GetChoice choice%
PRINT : PRINT
IF choice% THEN
   PRINT "Wow, I'm smart!"
   PRINT "(Press a key)"
   DO: LOOP UNTIL LEN(INKEY$)
ELSE
   LINE INPUT "What was your animal? ", useranimal$
   PRINT
   PRINT "Please type a yes/no question that differentiates a"
   PRINT useranimal$; " from a "; companimal$; ": ";
   LINE INPUT "", newanimal.animal
   PRINT
   PRINT "If your animal was a "; useranimal$; ", how would you answer"
   PRINT "the above question? ";
   GetChoice choice%
   records& = LOF(1) \ LEN(animal)
   newanimal.yes = records& + 1
   newanimal.no = records& + 2
   PUT #1, animalnum&, newanimal
   newanimal.animal = useranimal$
   newanimal.yes = -1
   newanimal.no = -1
   IF choice% THEN
      PUT #1, records& + 1, newanimal
      PUT #1, records& + 2, animal
   ELSE
      PUT #1, records& + 1, animal

      PUT #1, records& + 2, newanimal
   END IF
END IF

CLOSE #1

END SUB

'


' From:  JIM LITTLE                Sent: 07-17-93 03:10
'   To:  ALL                       Rcvd: -NO-
'   Re:  ANIMAL.DAT

'This is a sample data file for ANIMAL.BAS.  It isn't required,
'but you may enjoy the program more (at first, at least) if
'you unzip it into the directory containing ANIMAL.BAS.  Simply
'execute in a QB-related environment to get ANIMAL.ZIP, then
'unzip with PKUNZIP v2.04 or greater to get ANIMAL.DAT.
CLS:?STRING$(50,178):DEFINT A-Z 'Created by PostIt! 6.1
FOR A=0 TO 6:P(A)=2^A:NEXT:OPEN "B",1,"ANIMAL.ZIP
T$="abcdefghijklmnopqrstuvwxyz":T$=T$+UCASE$(T$)+"0123456789#$
G"qT0aeqb)icaCANXRrE1TM#My)WUl(Gc*b5usnfetUququ1Sw3Fj12aHNx69EVoH
G"uifinsVFbscqkKqi96y7X2kRSKpz5Bzj9Ep5p5elVl84wVoC238dz#byFlpM9tt
G"5BksNgC6W#SCfoZw7qYOkinwnvv8S4OLlbU0U6uR2GrLb95mUMXtoVkEa$gNbCM
G"D1ze5MSnW5NceSpvYMuP3nd9wKjFdI9EnJhMtWdRsuMmC$wBYP437SGZg2lz2Ko
G"t1Z2gOSrGBboWMp5egPCjOnflD8y0#5aNBhCwXNWdLmgl75bNFxFuo143ToYKXn
G"FvcgPP4jyL3Pk5Qt9pXfaxyp6uZzBH$$Rs#NgXRYyhkNucR31hLBRRySK9JdNxe
G"CXRm30KHPoBb6D8wXeUj5oGD2tUzTjHDzoBZFpqDgSNfwZeEgkMCvWv3fNHSYuv
G"v#iZMUt4U#V5LMsE2nmLFzWL3t85uokItWuEWU$NdwdswwNRxtXBdYURaUYoCDv
G"EYfo674G00QDmCDh87v5KBckNCtWn3J9mvzgz##oGBTBUzdWt4abQJhA8EqUg4A
G"xwNrQSaNIpNmn6ViK7pmfFdWn2ZzNqVR2mg3$1bx$QI5NWHQCrkpJj2HYJg87PA
G"MqbL7hEGEY31QbtYDs4K1CzJdXJcj3nCpl735J6vM4rYXhKuiRB8zbv08HrR07f
G"UVEILyvwUFuvpFi4H7QZKa$zIDQjeqft#48b1sYtbpDVX8PKjEg6j1andTXN2JI
G"sk3gC7DX5uMWyT1NpUi0aoZRlidkN8eWtUCS00CLFGmrDX5uRRafu2h8cDTNXKZ
G"nRLBM1Ji0$TH3z5ZEHk2zRITLdAyJLo7LSjRwjNx6XGhVB#UFwzB5OqF9JaQ7c2
G"DxD6SjSz8etpiSNL1PXg7RDMXtm9iWJ21V7S0aB7QJpQbx2Y6kuk5zGNTV#q0QY
G"s2nIm#2#Lkvjso4XbHxU$EggmZ5jXlrfvEbbAqNokksjwL4f88Ko2kibAcWIhZh
G"WPwjjkr85H9UmoDQKe2GrZW2IkdpanGZeBIffu#n437YlvsXt2DETXhgLnMCg1g
G"w3wVevlNSvtomIjHcrd6mZPo2X0ZetRZRDqX2y5Mq69Hpyz7zZFKPmKB0lz6RGV
G"w8DR9IWl1FFDw3eob9wtw9qAmPn#SwqJzJ8dWpcR54tgM7SQ5WhPAWEmP1nanEw
G"MH9B98P3fEVvS3Ms12yebC$WbwHo9HnQznOFQDelAOTEKHuAuo5iWB1JFVQXAo#
G"#KBW5egLtc6SX7QYiVvQQCVgCOvmRnnd5SXUQs8vGxTRoZcZCvO0JmbD##6cRMu
G"oP1Ek3y2NqNX2PIQZxhEJE5LQYTo$UW4ANEqJDQHIv0tBTb3GDZW1RvXtg8na4G
G"Q#Mps5B$wtwy3DewARJ3ABeTTEKkdLuom8M9T$tRvJP1JOX#57vK5suo5JHpPx$
G"EJB38$jEPkDTOoP29GvNPzJCRSlOZd5IfDhGT57ublz9O2zzSoX56sCuMKD0$HW
G"h1pVuOp5HEXelWzel5jhXnGPIFVmrq8k7PL2gn1MdQETNARjdn8GVoL57btNIck
G"ZN5swo5GoRnQyRtUa0253ZvgjhoSDVntLmBFbxhLPLoFFAojQo$f4xxDEePZOrU
G"T22zyvoknvoK#zWKEYJwVwP1JUF#sRlUUuzKcPgW2do91P#QWMvtB#hSM22NyAR
G"S$U24ZWlviohLsARXLRINWYMBQNze9cp8qDF8NgVEuR$Cr9D5NrOSbs5cVRYjKj
G"JCwXO7AN5Ivojp$T1oyrFgl4XGpV$3iXA1vEhPv0i2Zatz1A546pkmB18NjmLGf
G"nFACZD0#KDs1I9sw#g4B7S$ttJTSIh$ng3gFAjnj4#p$c4lxT9mIkIS2rb1f5Mj
G"sIZ$a#ZU4SWUbpFy7kTD6GN1Er8POnI8xWFFkUFZ51IAx24wSt02#5R9E2jxa63
G"bFFN3Za5ztaDhjNmtQYuBOmzdXK2##6QDI#EW#j4N78EfZBC7UJ$2Ti1GJWA97t
G"f963N3dM1k#8M51ffnUH2x9Py9ZBJe8wTxKVRzBSTYtfYCzSZTN6KW4LOqY87IS
G"uUf$E8CtN14TvuTtUZ#E2T3YjbEnViN$53vo3Ooumzb$j6RDEPgsA#CX6YCbJq$
G"xaqTuacqbau*G(N2z8AKxDRPVjg)S7c(O/ab(i/eKtj1uqm5crbrfulvGb+e(b(
G"o*oz,"
N=1692:K=255:IF LEN(C$)<>2256 THEN ?"Bad script!":END
FOR A=1 TO N:LOCATE 1:?STRING$(50/N*A,177):IF L=0 THEN GOSUB G:L=6
W=T\P(6-L):GOSUB G:W=W OR T*P(L):L=L-2:B$=CHR$(W AND K):PUT 1,,B$:NEXT
?:IF C=74 THEN ?"Ok":END ELSE ?"Bad checksum!":END
G:I=I+1:T=INSTR(T$,MID$(C$,I,1))-1:C=(C+T)*2:C=C\256+(C AND 255):RETURN
SUB G(A$):SHARED C$:FOR Q=2 TO 9:DO:S=INSTR(A$,CHR$(Q+38))
IF S THEN A$=LEFT$(A$,S-1)+STRING$(Q,97)+MID$(A$,S+1)
LOOP WHILE S:NEXT:C$=C$+A$:END SUB

'

' From:  CHRIS LATTNER             Sent: 07-18-93 11:41
'   To:  ALL                       Rcvd: -NO-
'   Re:  FUN & GAMES!
'
'    Hi everybody!  I recently downloaded the QuickBasic Scrapbook #3 and
'saw Quinn's Fun & games program.... I figured why not make this a
'general purpose file for playing music.  So I altered it so you can
'choose the music you want to play, and added the William Tell Overature.
'Here it is:

DEFINT A-Z

ON PLAY(3) GOSUB Music
PLAY ON

PLAY "O3MB"
EndOfMusic = 1: CLS
SCREEN 13

DO
    IF EndOfMusic = 1 THEN
         GOSUB Menu
    END IF
    IF RND > .3 THEN
         CenterPointX = RND * 320
         CenterPointY = RND * 200
    FOR A = 1 TO 250
         LINE (CenterPointX, CenterPointY)-(RND * 320, RND * 200), RND * 255
    NEXT A
ELSE
    FOR A = 1 TO RND * 75
         LINE -(RND * 320, RND * 200), RND * 255, BF
    NEXT A
END IF

IF INKEY$ <> "" THEN GOSUB Menu
LOOP

Menu:
    PLAY OFF
    DO UNTIL INKEY$ = "": LOOP 'Clear the keyboard buffer
    SCREEN 0: WIDTH 80: CLS
    LOCATE 24, 1
Menu2:
    PRINT "What shall we do?"
    PRINT
    PRINT "   0. End"
    PRINT "   1. Play Hello My Baby"
    PRINT "   2. Play an Italian song"
    PRINT "   3. Play the Hava Nagilah"
    PRINT "   4. Play the William tell Overature"
    PRINT ""
    INPUT "Hmm... ", A$
    A$ = UCASE$(LEFT$(A$, 1))
    SELECT CASE A$
         CASE "0"
              CLS
              PRINT "Chris Lattner 1993"
              PRINT "Modified and added to code by Quinn Tyler Jackson"
              END
         CASE "1", "A"
              RESTORE HelloMyBabyData
         CASE "2", "B"
              RESTORE ItalianData
         CASE "3", "C"
              RESTORE HavaNagilahData
         CASE "4", "D"
              RESTORE WillTell
         CASE ELSE
              PRINT : PRINT "What?  I don't understand!": PRINT
              GOTO Menu2
         END SELECT
    EndOfMusic = 0
    SCREEN 13
    PLAY ON
    GOSUB Music
RETURN

Music:
READ Bar$
IF Bar$ = "END_OF_SONG" THEN
    EndOfMusic = 1
ELSE
    PLAY Bar$
END IF
RETURN

HelloMyBabyData:
DATA "MlT200<C8MNDP32.MlC8DC<A8MNB-P32.MlA8B-AP32G8MNAP32.MlG8AGD<BAG>P32A8G"
DATA "P32F#8AG>C<<B-AG>P32F8AP32>C8EDC<<GAB->>C8MNDP32.MlC8DC<A8MNB-P32."
DATA "MlA8B-AP32G8MNAP32.MlG8AGDP32.DEFA8A8G2P32F#AG>T190MNCP64"
DATA "Ml<AF2<C8DC8DF2P32E32E-32D32D-32C32<B32B-32A32A-32G32G-32FP4>>"
DATA "END_OF_SONG"

ItalianData:
DATA "<<T225MSG8>MNC<E8EE8EMS>C8<BB8GG8AA8MNEP8MlE2MNP8E8DC8C<G8GG8GP16>E8DCC<G8GG8GG8"
DATA "G>MSG8>MNC<E8EE8E>C8<BB8MSGMNG8MSAMNA8EP8MlE2MNP32E8DC8C<G8GG8G8>P8E8D8C<G8GG8G"
DATA "G8G>MSE8E<MNB8BB8B>MSE8F#F#8MNEMSE8MNF#F#8E.MlE2.MNP8<B8BB8MlB1MNP8B8B8BG8GG8GG8GP16MS>G8
DATA "MNGD8DD8DMSG8AMNA8GG8AA8GD8GD8DMSD8MNDD8D<B8BB8BP16>D8DD8D<B8BB8BP16"
DATA "B8BB8>MlB.A8P4B.A8P4>MSCMN<B8A>C8<B<<D8<MlBA8>>B.A8MNP4B.A8P4>MSCMN<B8SA>C8<MSGE8EE8MNEE8EE8EE8EE8E"
DATA "E8EE8>C1DC8<A>C8<MSGE8MNEF8MSGMNF8ED8MlC1P4
DATA "END_OF_SONG"

HavaNagilahData:
DATA "T150<<MlDP64D.G-8E-8MND8MlG-P64G-.A8G8MNG-8MlGP64G.B-8A8G8P64G-E-8P64E8D.P16G-8P64G-E-8D8P64"
DATA "D8P64D8P8E-8P64E-D8C8P64C8P64C8P8CE-D16C8P64C8GP64G-E-8P64E-8DP4MNG2G2
DATA "MlG16P64G16P64MNG8P32MSB-8P16A16MNG8B-8A8G8P64MlG16P64G16P64MNG8P32MSB8P16A16MNG8B-8A8G8P64"
DATA "MlA16P64A16P64MNA8P32MS>C8P16<MNB-16A8>C8<B-8A8P64MlA16P64A16P64MNA8P3MS>C8P16<MNB-16A8>C8<B-8A8P64"
DATA "A16A16MSA8MN>D2<A16A16MSA8MN>D2<A16A16MNA8MN>D2.D-32MlC64<B64B-64A64A-4G64G-64F64E64E-64"
DATA "T170>><<MlDP64D.G-8E-8MND8MlG-P64G-.A8G8MNG-8MlGP64G.B-8A8G8P64G-E-8P6E-8D.P16G-8P64G-E-8D8P64"
DATA "D8P64D8P8E-8P64E-D8C8P64C8P64C8P8CE-D16C8P64C8GP64G-E-8P64E-8DP4MNG2G2
DATA "MlG16P64G16P64MNG8P32MSB-8P16A16MNG8B-8A8G8P64MlG16P64G16P64MNG8P32MSB8P16A16MNG8B-8A8G8P64"
DATA "MlA16P64A16P64MNA8P32MS>C8P16<MNB-16A8>C8<B-8A8P64MlA16P64A16P64MNA8P3MS>C8P16<MNB-16A8>C8<B-8A8P64"
DATA "A16A16MSA8MN>D2<A16A16MSA8MN>D2<A16A16MNA8MN>D2.D-32MlC64<B64B-64A64A-4G64G-64F64E64E-64"
DATA "T190>><<MlDP64D.G-8E-8MND8MlG-P64G-.A8G8MNG-8MlGP64G.B-8A8G8P64G-E-8P6E-8D.P16G-8P64G-E-8D8P64"

'

'Msg #:  1447                      QUIKBAS Subboard
' From:  CHRIS LATTNER             Sent: 07-18-93 11:46
'   To:  ALL                       Rcvd: -NO-
'   Re:  FUN & GAMES
'
'    Hi all!  I have edited Quinn's fun and games program to allow you
'to choose which song to play and I have added a song.  Here it is:
'
DEFINT A-Z
.
ON PLAY(3) GOSUB Music
PLAY ON

PLAY "O3MB"
EndOfMusic = 1: CLS
SCREEN 13
.
DO
        IF EndOfMusic = 1 THEN
                GOSUB Menu
        END IF
        IF RND > .3 THEN
                CenterPointX = RND * 320
                CenterPointY = RND * 200
        FOR A = 1 TO 250
                LINE (CenterPointX, CenterPointY)-(RND * 320, RND * 200), RND * 255
        NEXT A
        ELSE
        FOR A = 1 TO RND * 75
                LINE -(RND * 320, RND * 200), RND * 255, BF
        NEXT A
        END IF

IF INKEY$ <> "" THEN GOSUB Menu
LOOP

Menu:
        PLAY OFF
        DO UNTIL INKEY$ = "": LOOP 'Clear the keyboard buffer
        SCREEN 0: WIDTH 80: CLS
        LOCATE 24, 1
Menu2:
        PRINT "What shall we do?"
        PRINT
        PRINT "   0. End"
        PRINT "   1. Play Hello My Baby"
        PRINT "   2. Play an Italian song"
        PRINT "   3. Play the Hava Nagilah"
        PRINT "   4. Play the William tell Overature"
        PRINT ""
        INPUT "Hmm... ", A$
        A$ = UCASE$(LEFT$(A$, 1))
        SELECT CASE A$
                CASE "0"
                        CLS
                        PRINT "Chris Lattner 1993"
                        PRINT "Modified and added to code by Quinn Tyler Jackson"
                        END
                CASE "1", "A"
                        RESTORE HelloMyBabyData
                CASE "2", "B"
                        RESTORE ItalianData
                CASE "3", "C"
                        RESTORE HavaNagilahData
                CASE "4", "D"
                        RESTORE WillTell
                CASE ELSE
                        PRINT : PRINT "What?  I don't understand!": PRINT
                        GOTO Menu2
                END SELECT
        EndOfMusic = 0
        SCREEN 13
        PLAY ON
        GOSUB Music
RETURN
.
Music:
READ Bar$
IF Bar$ = "END_OF_SONG" THEN
        EndOfMusic = 1
ELSE
        PLAY Bar$
END IF
RETURN

HelloMyBabyData:
DATA "MlT200<C8MNDP32.MlC8DC<A8MNB-P32.MlA8B-AP32G8MNAP32.MlG8AGD<BAG>P32A8G
DATA "P32F#8AG>C<<B-AG>P32F8AP32>C8EDC<<GAB->>C8MNDP32.MlC8DC<A8MNB-P32."
DATA "MlA8B-AP32G8MNAP32.MlG8AGDP32.DEFA8A8G2P32F#AG>T190MNCP64"
DATA "Ml<AF2<C8DC8DF2P32E32E-32D32D-32C32<B32B-32A32A-32G32G-32FP4>>"
DATA "END_OF_SONG"

ItalianData:
DATA "<<T225MSG8>MNC<E8EE8EMS>C8<BB8GG8AA8MNEP8MlE2MNP8E8DC8C<G8GG8GP16>E8DCC<G8GG8GG8"
DATA "G>MSG8>MNC<E8EE8E>C8<BB8MSGMNG8MSAMNA8EP8MlE2MNP32E8DC8C<G8GG8G8>P8E8D8C<G8GG8G"
DATA "G8G>MSE8E<MNB8BB8B>MSE8F#F#8MNEMSE8MNF#F#8E.MlE2.MNP8<B8BB8MlB1MNP8B8B8BG8GG8GG8GP16MS>G8
DATA "MNGD8DD8DMSG8AMNA8GG8AA8GD8GD8DMSD8MNDD8D<B8BB8BP16>D8DD8D<B8BB8BP16"
DATA "B8BB8>MlB.A8P4B.A8P4>MSCMN<B8A>C8<B<<D8<MlBA8>>B.A8MNP4B.A8P4>MSCMN<B8SA>C8<MSGE8EE8MNEE8EE8EE8EE8E"
DATA "E8EE8>C1DC8<A>C8<MSGE8MNEF8MSGMNF8ED8MlC1P4
DATA "END_OF_SONG"

HavaNagilahData:
DATA "T150<<MlDP64D.G-8E-8MND8MlG-P64G-.A8G8MNG-8MlGP64G.B-8A8G8P64G-E-8P64E8D.P16G-8P64G-E-8D8P64"
DATA "D8P64D8P8E-8P64E-D8C8P64C8P64C8P8CE-D16C8P64C8GP64G-E-8P64E-8DP4MNG2G2
DATA "MlG16P64G16P64MNG8P32MSB-8P16A16MNG8B-8A8G8P64MlG16P64G16P64MNG8P32MSB8P16A16MNG8B-8A8G8P64"
DATA "MlA16P64A16P64MNA8P32MS>C8P16<MNB-16A8>C8<B-8A8P64MlA16P64A16P64MNA8P3MS>C8P16<MNB-16A8>C8<B-8A8P64"
DATA "A16A16MSA8MN>D2<A16A16MSA8MN>D2<A16A16MNA8MN>D2.D-32MlC64<B64B-64A64A-4G64G-64F64E64E-64"
DATA "T170>><<MlDP64D.G-8E-8MND8MlG-P64G-.A8G8MNG-8MlGP64G.B-8A8G8P64G-E-8P6E-8D.P16G-8P64G-E-8D8P64"
DATA "D8P64D8P8E-8P64E-D8C8P64C8P64C8P8CE-D16C8P64C8GP64G-E-8P64E-8DP4MNG2G2
DATA "MlG16P64G16P64MNG8P32MSB-8P16A16MNG8B-8A8G8P64MlG16P64G16P64MNG8P32MSB8P16A16MNG8B-8A8G8P64"
DATA "MlA16P64A16P64MNA8P32MS>C8P16<MNB-16A8>C8<B-8A8P64MlA16P64A16P64MNA8P3MS>C8P16<MNB-16A8>C8<B-8A8P64"
DATA "A16A16MSA8MN>D2<A16A16MSA8MN>D2<A16A16MNA8MN>D2.D-32MlC64<B64B-64A64A-4G64G-64F64E64E-64"
DATA "T190>><<MlDP64D.G-8E-8MND8MlG-P64G-.A8G8MNG-8MlGP64G.B-8A8G8P64G-E-8P6E-8D.P16G-8P64G-E-8D8P64"
DATA "D8P64D8P8E-8P64E-D8C8P64C8P64C8P8CE-D16C8P64C8GP64G-E-8P64E-8DP4MNG2G2
DATA "MlG16P64G16P64MNG8P32MSB-8P16A16MNG8B-8A8G8P64MlG16P64G16P64MNG8P32MSB8P16A16MNG8B-8A8G8P64"
DATA "MlA16P64A16P64MNA8P32MS>C8P16<MNB-16A8>C8<B-8A8P64MlA16P64A16P64MNA8P3
DATA "mbl16T155o2mnb4p8mWillTell:.DATA "END_OF_SONG"
DATA "D64D-64C64<B64
'

' From:  KELLY MUNDELL             Sent: 07-15-93 09:56
'   To:  TROY JONES                Rcvd: -NO-
'   Re:  A FEW QUESTIONS.
'
'-=- What did John say to Troy about A FEW QUESTIONS.?  Sheesh! -=-
'
' TJ> Also, some QB code that has full editing? Like INS, DEL, backspace
' TJ> editing, all that and such.  Anyone?  I didn't feel like having to deal
' TJ> with all the string manipulation if I didn't have to.  Thanks.
'
'Look at the following ::: a full editing input routine...

'The following input routine, with full editing and DOS shell, was
'written by myself years ago in GWBasic and has been enhanced through the
'last few years by myself and programming partner James Parchen.  It is
'released into this echo as public domain.  If you improve this routine,
'please let me know.  Any comments and/or critisism would be greatly
'appreciated.

DEFINT A-Z
SUB KeyIn (Ver$, Ln$, Mask$, Fg, Bg, p)

'Ln$ = SPACE$(Number of Charecters to accept)
'Ver$ = "ALL"          ' All Characters
'Ver$ = "a-z"          ' Alpha Lower Case
'Ver$ = "A-Z"          ' Alpha Upper Case
'Ver$ = "a-Z"          ' Alpha Case off
'Ver$ = "#'s"          ' Numbers Only
'Mask$ = ""
'Fg Foreground color
'Bg Background color
'p  Can't remember why this variable is in argument list but if it is 0
'   or 1 the routine should work fine.

DIM Chk(10)
IF Mask$ <> "" THEN
   Ln$ = Mask$
   FOR Chk = 1 TO LEN(Mask$)
      IF MID$(Mask$, Chk, 1) <> " " THEN Temp$ = Temp$ + STR$(Chk)
   NEXT Chk
   Mask$ = Temp$
END IF
S = POS(0): L = LEN(Ln$): COLOR Fg, Bg: PRINT Ln$; : IF p = 0 THEN p = 1

IF p > L THEN p = L + 1

LOCATE , S + p - 1, 1, 7, 7: Temp$ = ""

Alpha$ = " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Num$ = " 0123456789"

IF UCASE$(LEFT$(Ver$, 4)) = "A-Z#" THEN Ver$ = Alpha$ + Num$ + MID$(Ver$, 5)

SELECT CASE LEFT$(Ver$, 3)
   CASE "ALL": Caps = 0: Ver$ = Alpha$ + Num$ + "!@#$%^&*()-_+=\[]{};':,./<>? "
   CASE "A-Z": Caps = 1: Ver$ = Alpha$ + MID$(Ver$, 4)
   CASE "a-z": Caps = 2: Ver$ = Alpha$ + MID$(Ver$, 4)
   CASE "a-Z": Caps = 0: Ver$ = Alpha$ + MID$(Ver$, 4)
   CASE "#'s": Caps = 0: Ver$ = Num$ + MID$(Ver$, 4)
   CASE ELSE: Caps = 0
END SELECT
a = 0: e = 0
WHILE a <> 13 AND a <> 27 AND a <> 10
   DO
      IF Caps = 0 THEN a$ = INKEY$
      IF Caps = 1 THEN a$ = UCASE$(INKEY$)
      IF Caps = 2 THEN a$ = LCASE$(INKEY$)
   LOOP UNTIL a$ <> ""
   a = ASC(a$): IF a = 0 THEN a = ASC(RIGHT$(a$, 1)) * -1
   p = POS(0) - S + 1: R = POS(0)
   'SCREEN , , 0, 0: COLOR 7, 0: CLS : PRINT a: END
     'Remove the above rem to see the value returned by variable `a' for
     'a specific key.  Extended keys are assigened a - value so we can
     'use just one variable for the keys.

   SELECT CASE a
      CASE -32                                            ' ALT-D For Dos Shell
         SCREEN , , 0, 0: CLS
         SHELL "Type EXIT [ENTER] To Return To Program"
         SHELL
      CASE -77: IF p < L + 1 THEN PRINT CHR$(28);  ELSE BEEP    ' Right arrow
      CASE -75: IF p <> 1 THEN PRINT CHR$(29);                  ' Left arrow
      CASE -71: LOCATE , S                                      ' <Home>
      CASE -119                                                 ' <Ctrl+Home>
         LOCATE , S: Ln$ = SPACE$(L): PRINT Ln$; : LOCATE , S
      CASE -79
         LOCATE , LEN(RTRIM$(Ln$)) + S                          ' <End>
      CASE -117                                                 ' <Ctrl+End>
         Ln$ = LEFT$(Ln$, p - 1) + SPACE$(L - p + 1)
         LOCATE , S, 0: PRINT Ln$; : LOCATE , R, 1
      CASE -116                                           ' <Ctrl+RightArrow>
         IF p <= L THEN
            Chk = INSTR(p, Ln$, " ")
            IF Chk <> 0 THEN
               Temp$ = LEFT$(LTRIM$(MID$(Ln$, Chk)), 1)
               IF Temp$ <> "" THEN LOCATE , S - 1 + INSTR(Chk, Ln$, Temp$), 1
            ELSE
               LOCATE , LEN(RTRIM$(Ln$)) + S
            END IF
         END IF
      CASE -115                                          ' <Ctrl+LeftArrow>
        Temp$ = RTRIM$(LEFT$(Ln$, p - 1))
        IF INSTR(Temp$, " ") THEN
           DO WHILE INSTR(Temp$, " ")
              Chk = INSTR(Temp$, " "): MID$(Temp$, Chk, 1) = "X"
           LOOP
           LOCATE , Chk + S, 1
        ELSE
           LOCATE , S
        END IF
      CASE 8                                              ' <Back Space>
         IF p <> 1 THEN
            Ln$ = LEFT$(Ln$, p - 2) + MID$(Ln$, p) + " "
            LOCATE , S, 0: PRINT Ln$; : LOCATE , R - 1, 1
         ELSE
            Ln$ = RIGHT$(Ln$, L - 1) + " ": LOCATE , S, 0: PRINT Ln$;
            LOCATE , p + S - 1, 1
         END IF
      CASE 127                                             ' <Ctrl+BckSpc>
         IF p > L THEN p = L
         Ln$ = SPACE$(p) + MID$(Ln$, p + 1)
         LOCATE , S, 0: PRINT Ln$; : LOCATE , R, 1

      CASE -83                                                  '<Delete>
         IF p <= L THEN
            Ln$ = LEFT$(Ln$, p - 1) + MID$(Ln$, p + 1) + " "
            LOCATE , S, 0: PRINT Ln$; : LOCATE , R, 1
         END IF
      CASE -82                                                 ' <Insert>
           IF insert = 0 THEN insert = 1 ELSE insert = 0
           IF insert = 0 THEN LOCATE , , 1, 7, 7
           IF insert = 1 THEN LOCATE , , 1, 4, 7
      CASE ELSE
         IF INSTR(Ver$, a$) AND p <= L THEN                 ' Print Character
            IF insert = 1 THEN
               Ln$ = LEFT$(Ln$, p - 1) + a$ + MID$(Ln$, p, L - p + 1)
               LOCATE , , 0: PRINT MID$(Ln$, p, L - p + 1); : LOCATE , R + 1, 1
            ELSE
               PRINT a$; : MID$(Ln$, p, 1) = a$
            END IF
            IF INSTR(Mask$, STR$(p + 1)) THEN PRINT MID$(Ln$, p + 1, 1);
         ELSE IF a <> 13 AND a <> 27 THEN BEEP
         END IF
      END SELECT
   WEND
   IF a = 27 THEN
      Ln$ = SPACE$(L)
      GOTO EndKeyIn
   END IF
EndKeyIn:
Ln$ = RTRIM$(Ln$)

END SUB
'


 From:  LOGAN ASHBY               Sent: 07-19-93 16:55
   To:  TOM TREMAIN               Rcvd: -NO-
   Re:  HELP 1/2

Answering a msg of <13 Jul 93>, from Tom Tremain to All:

 TT> I'm trying to figure out a couple of things in QB, I could
 TT> use some help.

 TT> 1)  How to tell if a drive is
 TT>         a) a subst drive
 TT>         b) network drive
 TT>         c) ram drive

    I'm not even sure exacty what question 2 was asking, but here's some
code to handle #1.  This has at least one known bug in that it gives
incorrect results if you have a drive letter subst'ed to a directory on
a floppy.  Its method of determining phantom drives ain't exactly
bulletproof, either ;-). Maybe it'll give you a place to start, anyway.

 '---------------- begin code -----------------------

 ' --------------------------- TRUNAME.BAS ---------------------------
 '|  Checks for physical and logical drives on a system, returns      |
 '|  the truename for SUBSTed and JOINed drives                       |
 '|  Logan Ashby - 04/17/92 - Released to Public Domain               |
 ' -------------------------------------------------------------------
 '$INCLUDE: 'QBX.BI'
 DEFINT A-Z

 DECLARE FUNCTION IsRemoveable% (DrvNum%)
 DECLARE SUB TrueName (DrvNum%, DrvType%, RemappedTo$)

 CONST FALSE = 0
 CONST TRUE = -1
 CONST PHYSICAL = 0                  '| Constants for drive type
 CONST LOGICAL = 1                   '|  possibilities.
 CONST NETWORK = 2
 CONST PHANTOM = 3
 CONST RAMDRV = 4

 DIM SHARED RegsX AS RegTypeX
 COMMON SHARED Null$

 Null$ = CHR$(0)

 CLS
 RegsX.ax = &H1900                   '| Get starting crnt drive
 CALL InterruptX(&H21, RegsX, RegsX)
 CurDrv% = RegsX.ax

 FOR i% = 0 TO 25
     RegsX.ax = &HE00                '| Set CurrentDrive
     RegsX.dx = i%
     CALL InterruptX(&H21, RegsX, RegsX)

     RegsX.ax = &H1900               '| Did it take?
     CALL InterruptX(&H21, RegsX, RegsX)

     IF ((RegsX.ax AND &HFF) = i%) THEN
     ' ----------------------------------------------------------
     '| OK, we got a valid drive letter,  lets see what type of  |
     '|   drive it is.                                           |
     ' ----------------------------------------------------------
         DrvLtr$ = CHR$(i% + 65)
         PRINT "Drive "; DrvLtr$; " is: ";
         CALL TrueName(i%, DrvType%, RemappedTo$)
         SELECT CASE DrvType%
         CASE PHYSICAL:
             PRINT " Physical Drive "

         CASE LOGICAL:
             PRINT " Logical Drive : "; RemappedTo$

         CASE NETWORK:
             PRINT " Network Drive : "; RemappedTo$

         CASE PHANTOM:
             PRINT " Phantom Drive : "; RemappedTo$

         CASE RAMDRV:
             PRINT " Ram Drive"

         END SELECT
     END IF
 NEXT i%

 RegsX.ax = &HE00                    '| Restore original Drive
 RegsX.dx = CurDrv%
 CALL InterruptX(&H21, RegsX, RegsX)

 END

 ' --------------------------------------------------------------
 '| We need to test for a floppy with this method, as the        |
 '|  truename function will poll the hardware, and generate a    |
 '|  crit. error if no floppy in drive/door open                 |
 ' --------------------------------------------------------------
 FUNCTION IsRemoveable% (DrvNum%)
     RegsX.ax = &H4408
     RegsX.bx = DrvNum% + 1
     CALL InterruptX(&H21, RegsX, RegsX)
     IF (RegsX.Flags AND 1) THEN
         ' ------------------------------------------------------
         '| Could handle this error better. For now, just assume |
         '|   it's not a floppy, as this code generates an error |
         '|   for a Novell mapped drive.                         |
         ' ------------------------------------------------------
         IsRemoveable% = FALSE
     ELSE
         IF (RegsX.ax) THEN
             IsRemoveable% = FALSE
         ELSE
             IsRemoveable% = TRUE
         END IF
     END IF
 END FUNCTION

 ' --------------------------------------------------------------
 '| Get the true name of the drive letter, using Int &H21,       |
 '|  Function &H60.  Available since DOS 3.0, but not documented |
 '|  until 5.0                                                   |
 '| Modified 7/19/93 to detect ramdisks, phantom drives, and     |
 '|  network drives.                                             |
 ' --------------------------------------------------------------
 SUB TrueName (DrvNum%, DrvType%, ReMapped$)
     DIM DrvPath AS STRING * 128
     IF (IsRemoveable%(DrvNum%)) THEN
         ' ------------------------------------------------------
         '| Check for a phantom drive.  The assumption is that   |
         '|  if the drive letter is A: or B: and the system only |
         '|  has one floppy, the other is a phantom drive.  We   |
         '|  check the BIOS to see which letter is currently     |
         '|  being used to access the hardware.                  |
         ' ------------------------------------------------------
         DEF SEG = 0
         NumFlpys% = ((PEEK(&H410) AND &HC0) \ 64) + 1
         IF (NumFlpys% = 1) THEN
             CrntFlpy% = PEEK(&H504)
             IF ((DrvNum% < 2) AND (CrntFlpy% <> DrvNum%)) THEN
                 DrvType% = PHANTOM
                 ReMapped$ = _
                     "Mapped to floppy hardware when requested"
             ELSE
                 DrvType% = PHYSICAL
                 ReMapped$ = ""
             END IF
         ELSE
             DrvType% = PHYSICAL
             ReMapped$ = ""
         END IF
         DEF SEG
     ELSE                            '| The period after the
                                     '|  backslash here avoids a
                                     '|  Novell bug
         DrvLtr$ = CHR$(DrvNum% + 65) + ":\." + Null$
         DrvPath = DrvLtr$           '| TrueName function
         RegsX.ax = &H6000
         RegsX.di = VARPTR(DrvPath)  '| We use the same buffer
         RegsX.si = RegsX.di         '|  for the input and
         RegsX.ds = VARSEG(DrvPath)  '|  output
         RegsX.es = RegsX.ds
         CALL InterruptX(&H21, RegsX, RegsX)
         DrvLtr$ = LEFT$(DrvLtr$, 3)
         TmpPath$ = LEFT$(DrvPath, INSTR(DrvPath, Null$) - 1)
         IF (DrvLtr$ <> TmpPath$) THEN
             IF (INSTR(DrvPath, "\\")) THEN
                 DrvType% = NETWORK
             ELSE
                 DrvType% = LOGICAL
             END IF
             ReMapped$ = TmpPath$
         ELSE
             RegsX.ax = &H3200       '| Get Drive Parameter
             RegsX.dx = DrvNum% + 1  '|  Block for this drive
             CALL InterruptX(&H21, RegsX, RegsX)
             DEF SEG = RegsX.ds      '| Get the # of FAT's
             NumFATS% = PEEK(RegsX.bx + 8)
             DEF SEG
             IF (NumFATS% = 1) THEN  '| A non-removeable drive w/
                 DrvType% = RAMDRV   '|  only one FAT is usually

             ELSE                    '|  a RAM drive.
                 DrvType% = PHYSICAL
             END IF
             ReMapped$ = ""
         END IF
     END IF
 END SUB

'

 From:  CHAD GUNTER               Sent: 07-20-93 22:12
   To:  BILL NORCROSS             Rcvd: -NO-
   Re:  SOFTWARE RESET

   Bill, I had that same question some time ago - I got two responses
and I'll give 'em to ya:


'Date: 04-0793 (04:29)
Number: 24943 of 25295 '  To: CHAD GUNTER
     Read: 04-11-93 (21:14) 'Subj: REBOOT


'CG> Does anyone know how to make the computer reboot from inside QB? Thanx!
'Here you go:
'============================== Begin code==============================
DEFINT A-Z
'$INCLUDE: 'qb.bi'
'replace with qbx.bi if you're using PDS
DECLARE SUB Reboot (BootType%)
call reboot(0) 'warm boot. NON-ZERO is cold boot.
'**********************************************************************
'* SUB Reboot
'*
'*    Reboots the machine by executing the machine language procedure
'*    located at FFFF:0000.
'*
'* EXTERNAL ROUTINE(S)
'*    QBX.LIB
'*    -------
'*    SUB Absolute (Address%)
'**********************************************************************
 SUB Reboot (BootType%) STATIC
   DEF SEG = &H40
   POKE &H72, 0 - ((BootType% = 0) * &H34)   'if BootType% = 0, perform
   POKE &H73, 0 - ((BootType% = 0) * &H12)   '  a warm boot, else a cold boot
   DEF SEG = &HFFFF                          'set segment to bootstrap loader
   Absolute 0                                'do system call END SUB
'=============================== End code===============================

'Set BootType% = 0 to perform a warm boot, or anything else to perform a
'cold boot. '


'CG>Does anyone know how to make the computer reboot from inside QB?
'======================================================================
'From: ZACK JONES
'> I search how to entry a command for REBOOT the computer  in QB45.
'Try this: 'From PC Magazine, 17 Mar 92, Page 439
DECLARE SUB
ReBoot(Warm%) CALL ReBoot(1) 'Save this program before running it!

SUB ReBoot (Warm%) STATIC
  IF Warm% THEN              'if they want a warm boot
    DEF SEG = 0              'assign the value 1234 Hex
    POKE &H473, &H12         'to address 0000:0472 Hex
    POKE &H472, &H34
  END IF
  DEF SEG = &HFFFF           'either way call the BIOS
  CALL Absolute(0)           'routine at FFFF:0000 Hex END SUB

END SUB
'
' From:  VICTOR YIU                Sent: 07-22-93 14:19
'   To:  ALL                       Rcvd: -NO-
'   Re:  POSTIT! 7.0 ANNOUCEMENT!
'
'+----- Here's the PostIt! 7.0 everybody's been waiting for! -------
'|    To:  ALL
'|  From:  Rich Geldreich
'|  Subj:  PostIt! 7.0
'+-----------------------------------
'    The following 10 messages contain the source code for PostIt! v7.1.
'
'
'    This version was rewritten totally from scratch, by me. It's now a
'command line utility, like it should of been from the beginning.
'
'    I feel pretty sure that no major bugs exist in this version. I spent
'a lot of time debugging & testing it. If you find any bugs, please
'inform Victor Yiu or me and we'll fix them up.
'
'    The first message contains instructions about how to use this
'version of PostIt! If something still remains fuzzy after you read this,
'please ask either Victor or me and we'll clear things up for you.
'
''>>> Page 1 of PI71.BAS begins here. TYPE:BAS
' PostIt! v7.1 Script Encoder/Decoder-Public Domain-July 1993
' By Rich Geldreich & Victor Yiu. Many  contributions,   fixups,  and
' features by Mark H. Butler,  Quinn Tyler Jackson, and Scott Wunsch.
'
' PostIt! can  encode   any  binary   file  into  a  series  of self-
' extracting  script  files  that  can  be  reliably  distributed  on
' text-only  conferences  or  networks.   The  script  files  can  be
' extracted with  this  program,  or  with  any  Microsoft QuickBASIC
' language (DOS 5's QBASIC, QB4.5, PDS, VB-DOS) because  each  script
' contains its own small QuickBASIC decoder.
'
' PostIt!   can  also  format  QuickBASIC  source  code  suitable for
' distribution on conferences, and reconstruct source code  formatted
' by  this  program.   This  allows  QuickBASIC programmers to easily
' exchange BASIC source code without worrying about the annoying line
' length and message limitations of most networks.
'
' New 7.1 Features
'
' o  Totally rewritten source code!
' o  Much  more efficient  encoding algorithm (MOD 86 encoding)  with
'    a smaller and faster self extractor!
' o  Huge binary scripts now supported, up to 150k!
' o  The  script decoding & unfiltering functions  are now automated!
'    As  long  as a few  simple rules are followed (see the  notes on
'    the Decode command), no  user intervention  is needed to extract
'    multiple scripts from the same capture file.
' o  PostIt!  is  finally  a command line utility! Error codes can be
'    returned  to batch  files if  you're compiling   with  VBDOS  or
'    QBX.   Look  at the source to  find out  which error  code means
'    which.
' o  The format of PostIt!'s   message  headers has finally been well
'    thought out and (hopefully) finalized.  Although   compatibility
'    with  previous versions of PostIt!  has been sacrificed, scripts
'    created by  newer versions  of  PostIt!   should be decodable by
'    this version because of a common message header format.
'
' Explanation of Commands
'
' E = Encodes  any binary  file less than 150k into a self-extracting
'     text-only script.  If the -s  option is used with this command,
'     the entire script will be written to one output file; otherwise
'     the script will be split into multiple output files, where each
'     output file contains one message.   (Note:  Scripts created  by
'     this  command  cannot  be  extracted  by  previous  versions of
'     PostIt!.)
'
' F = Filters QuickBASIC source code for  posting  on  a  conference.
'     This  command  actually  performs  two filtering functions.  It
'     splits very long  lines  with  continuation characters (special
'     precautions are taken to ensure  quoted strings and remarks are
'     split correctly), and chops the source code into multiple files
'     so each file corresponds to one message  (unless the -s  option
'     is used).The filtered file can still be executed or compiled by
'     QuickBASIC, just as the original could.  (Note: DATA statements
'     split by filtering cannot be unsplit correctly by QB! This will
'     hopefully  be fixed  soon...   Files  filtered  by this command
'     cannot by unfiltered by previous versions of PostIt!.)
'
' D = Decodes binary/text scripts.  Multiple scripts can  be  decoded
'     from the same  input  file  with  this  function.  The decoding
'     algorithm  automatically  decides  which  method  was  used  to
'     encode the source file(binary script or source code filtering).
'
'     If  any  errors  are  encountered during decoding the script is
'     skipped  and the  partly decoded  file is deleted.
'
'     Binary and text scripts created by previous versions of PostIt!
'     cannot be decoded with this command, because of the new  header
'     format employed by this version of PostIt!.
'
'     (Notes:  Pages of a script MUST appear in increasing order.  In
'     other words, page 2 must follow page 1, page 3 must follow page
'     2, etc.  When posting  files  created  by  the E or F commands,
'     don't modify or remove the message headers because the decoding
'     algorithm expects these to indicate the beginning and ending of
'     each page.  (All message headers begin with a "'>>>" sequence.)
'     Finally, if an output file is specified on  the  command  line,
'     for  example "POSTIT D capture.txt c:\q\coolcode.zip", only the
'     specified output file  (COOLCODE.ZIP  in  the  example) will be
'     decoded if its script can be  located.   The  pathname  of  the
'     output  file  will  be  the  destination  path specified on the
'     command line.  In the  example,  the  file COOLCODE.ZIP will be
'     written to the C:\Q directory.)
'
' Completely stupid and irrelevant examples for the Average Fool
'
' postit e maim.zip -p95 -b20 c:\scripts\mc

' (Encodes a binary script of MAIM.ZIP. All output file(s) are written
'  to the C:\SCRIPTS directory and begin with the "MC" suffix. The
'  message length is 95 lines, and 20 blank lines are reserved on the
'  first message.)
' postit -a f x-ray.bas -o -s
' (Filters the file X-RAY.BAS for posting. All blank lines are padded
'  with a space, no prompting is done for file overwrites, and no
'  message splitting is performed.)
' postit d zebra.txt q\
' (Decodes all scripts from the file ZEBRA.TXT to the Q directory.)
'
DEFINT A-Z
DECLARE FUNCTION Decode% (oSwitch%, InSpec$, OutSpec$)
DECLARE FUNCTION Encode% (Op%, iSwitch%, cSwitch%, aSwitch%, tSwitch%, sSwitch%, pSwitch%, lSwitch%, oSwitch%, bSwitch%, InSpec$, OutSpec$)
DECLARE SUB ExpandLine (A$, Lines$(), LineLength%, NumLines%)
DECLARE FUNCTION FASC% (A$)
DECLARE FUNCTION GrabNum& (A$, Lower&, Upper&, Default&)
DECLARE SUB ParseCmdLine (Cmd$, Params$(), Found%)
DECLARE SUB SepPath (A$, Drive$, path$, tName$)
DECLARE FUNCTION UnTab$ (B$, TabStops%)


CONST True = -1, False = 0, Debug% = False
DIM SHARED GERR%: ON ERROR GOTO ErrHandler
LOCATE , , 1
PRINT "PostIt! v7.1 QuickBASIC Compatible Encoder/Decoder"
PRINT "Public Domain by Rich Geldreich and Victor Yiu"
PRINT
IF FRE(-1) < 65536 THEN ErrLvl% = 1: PRINT "Not enough memory": GOTO AllDone
DIM Params$(1 TO 10)
'The following line must be modified for DOS 5 QBASIC.
ParseCmdLine COMMAND$, Params$(), NumParams%
IF NumParams% = 0 THEN ErrLvl% = 2: GOTO ShowHelp
FOR I% = 1 TO NumParams%
  Q$ = Params$(I%)
  IF LEFT$(Q$, 1) <> "-" AND LEN(Q$) = 1 THEN
    Command% = INSTR("EFD", Q$)
    IF Command% <> 0 THEN
      Params$(I%) = "": EXIT FOR
    ELSE
      PRINT "Bad command: "; Q$: PRINT : ErrLvl% = 3: GOTO ShowHelp
    END IF
  END IF
NEXT
IF Command% = 0 THEN PRINT "No command specified.": PRINT : ErrLvl% = 4: GOTO ShowHelp
IF Command% = 2 THEN DefaultLineLength% = 72 ELSE DefaultLineLength% = 65
sSwitch% = False: pSwitch% = 85: lSwitch% = DefaultLineLength%
tSwitch% = 4: oSwitch% = False: bSwitch% = 0: aSwitch% = False
iSwitch% = False: cSwitch% = False
FOR I% = 1 TO NumParams%
  Q$ = Params$(I%): Z$ = MID$(Q$, 3)
  IF LEN(Q$) THEN
    IF LEFT$(Q$, 1) = "-" THEN
      SELECT CASE MID$(Q$, 2, 1)
      CASE "S": sSwitch% = True
      CASE "P": pSwitch% = GrabNum&(Z$, 45, 1000, 85)
      CASE "L": lSwitch% = GrabNum&(Z$, 60, 80, CLNG(DefaultLineLength%))
      CASE "T": tSwitch% = GrabNum&(Z$, 1, 8, 4)
      CASE "O": oSwitch% = True
      CASE "B": bSwitch% = GrabNum&(Z$, 0, 30, 0)
      CASE "A": aSwitch% = True
      CASE "I": iSwitch% = True
      CASE "C": cSwitch% = True
      CASE ELSE: PRINT "Bad switch: "; Q$: PRINT : ErrLvl% = 3: GOTO ShowHelp
      END SELECT
    ELSE
      SELECT CASE J%
      CASE 0: InputSpec$ = Q$
      CASE 1: OutputSpec$ = Q$
      CASE ELSE: PRINT "Too many filenames.": PRINT : ErrLvl% = 5:
GOTO ShowHelp
      END SELECT: J% = J% + 1
    END IF
  END IF
NEXT
IF J% < 1 THEN PRINT "Must specify input file.": PRINT : ErrLvl% = 5: GOTO ShowHelp
SepPath InputSpec$, InputDrive$, InputPath$, InputName$
IF INSTR(InputName$, ".") = 0 THEN
  IF Command% = 1 THEN     'encoding  .ZIP
    InputSpec$ = InputSpec$ + ".ZIP"
  ELSEIF Command% = 2 THEN 'filtering .BAS
    InputSpec$ = InputSpec$ + ".BAS"
  ELSEIF Command% = 3 THEN 'decoding  .TXT
    InputSpec$ = InputSpec$ + ".TXT"
  END IF
ELSE
  IF Command% = 1 THEN
    SELECT CASE MID$(InputName$, INSTR(InputName$, ".") + 1, 3)
    CASE "ZIP", "LZH", "ARJ", "GIF", "SQZ", "ZOO", "ARC", "HAP", "JPG"
    CASE ELSE: PRINT "Warning: Uncompressed files should not be encoded" + " into binary scripts!": PRINT
  END SELECT
  END IF
END IF
OPEN InputSpec$ FOR INPUT AS #1: CLOSE #1
IF GERR% THEN PRINT "Can't open "; InputSpec$: ErrLvl% = 6: GOTO AllDone
SepPath OutputSpec$, OutDrive$, OutPath$, OutName$
TestFile$ = OutDrive$ + OutPath$ + "pi742875.2yz"
OPEN TestFile$ FOR OUTPUT AS #1: CLOSE #1
IF GERR% THEN PRINT "Bad output specification.": ErrLvl% = 7: GOTO AllDone
KILL TestFile$
SELECT CASE Command%
CASE 1: Status% = Encode%(0, iSwitch%, cSwitch%, aSwitch%, tSwitch%, sSwitch%, pSwitch%, lSwitch%, oSwitch%, bSwitch%, InputSpec$, OutputSpec$)
CASE 2: Status% = Encode%(1, iSwitch%, cSwitch%, aSwitch%, tSwitch%, sSwitch%, pSwitch%, lSwitch%, oSwitch%, bSwitch%, InputSpec$, OutputSpec$)
CASE 3: Status% = Decode%(oSwitch%, InputSpec$, OutputSpec$)
END SELECT
IF Status% < 0 THEN ErrLvl% = 8 ELSE IF Status% > 0 THEN ErrLvl% = 9 ELSE ErrLvl% = 0
GOTO AllDone
ShowHelp:
PRINT "Usage: POSTIT [switch] command inputfile [outputfile]"
PRINT
PRINT "Commands:"
PRINT "e [E]ncode any file <150k into a self extracting binary script"
PRINT "f [F]ilter QB source into a text script"
PRINT "d [D]ecode captured text or binary script(s)"
PRINT
PRINT "Switches:"
PRINT "-s  Don't split output file into multiple messages"
PRINT "-o  Don't prompt for file overwrites"
PRINT "-b# Reserve # blank lines on first message (0-30, default=0)"
PRINT "-t# Set tab stops to # characters (1-8, default=4)"
PRINT "-l# Set line length to # characters (60-80, default=65 or 72)"
PRINT "-p# Set message length to # lines (45-1000, default=85)"
PRINT "-a  Padd blank lines with a space when filtering"
PRINT "-i  Ignore blank lines when filtering"
PRINT "-c  Crush space characters from start of lines when filtering"
AllDone:
IF Debug% THEN PRINT "Exiting with an errorlevel of"; ErrLvl%
END ErrLvl% 'Change this to just "END" if running with QB4.5
ErrHandler: GERR% = ERR
  IF Debug% THEN IF GERR% <> 53 THEN PRINT "Global error #"; GERR%
RESUME NEXT

'

FUNCTION Decode% (oSwitch%, InSpec$, OutSpec$)
  DIM Lines$(1 TO 256), ValidChar%(255)
  FOR Q% = 0 TO 85 'Valid encoding characters
    IF Q% = 27 THEN
      ValidChar%(ASC("#")) = True
    ELSEIF Q% = 59 THEN
      ValidChar%(ASC("$")) = True
    ELSE
      ValidChar%(Q% + 37) = True
    END IF
  NEXT
  GERR% = 0: Z$ = "OPEN " + CHR$(34) + "O" + CHR$(34) + ",1," + CHR$(34)
  SepPath OutSpec$, OutDrive$, OutPath$, OutName$
  OutPath$ = OutDrive$ + OutPath$
  InputHandle% = FREEFILE
  OPEN InSpec$ FOR INPUT AS InputHandle% LEN = 8192
  OutputHandle% = FREEFILE
  DO
    IF FoundNewScript% = False THEN
      DO UNTIL EOF(InputHandle%)
        M% = M% + 1: IF M% = 16 THEN GOSUB AbortCheck
        LineNum& = LineNum& + 1
        LINE INPUT #1, A$: A$ = LTRIM$(RTRIM$(UCASE$(A$)))
        IF GERR% THEN PRINT "Error while reading from input file!": GOTO DecodeExit
        IF LEFT$(A$, 14) = "'>>> PAGE 1 OF" AND INSTR(A$, "BEGINS" + " HERE") > 0 AND INSTR(A$, "TYPE:") > 0 THEN EXIT DO
      LOOP
      IF EOF(InputHandle%) THEN EXIT DO
    END IF
    FoundNewScript% = False
    OutFile$ = LTRIM$(MID$(A$, 15))
    OutFile$ = RTRIM$(LEFT$(OutFile$, INSTR(OutFile$, "BEGINS") - 1))
    IF LEN(OutFile$) = 0 THEN GOTO FindNext
    IF LEN(OutName$) = 0 OR OutFile$ = OutName$ THEN
      FilesCRC% = -1: FilesLength& = -1: ScrDone% = False
      BadScript% = False: NumLines% = 0: K% = 0: s% = 0: B& = 0
      Q% = INSTR(A$, "TYPE:") + 5
      SELECT CASE MID$(A$, Q%, 3)
      CASE "BAS": ScriptType% = 0
      CASE "BIN"
        ScriptType% = 1
        EncodeVer% = FASC%(MID$(A$, Q% + 3, 1)) - 65
        ExtractVer% = FASC%(MID$(A$, Q% + 4, 1)) - 65
        IF ExtractVer% <> 0 THEN PRINT "Unsupported encoding algorithm" + " for file "; OutFile$: PRINT : GOTO FindNext
      CASE ELSE: PRINT "Unsupported script type for file "; OutFile$: PRINT : GOTO FindNext
      END SELECT
      GOSUB CheckLine
      OPEN OutPath$ + OutFile$ FOR INPUT AS OutputHandle%: CLOSE OutputHandle%
      IF GERR% = 0 THEN
        IF oSwitch% = False THEN
          PRINT OutPath$ + OutFile$; " already exists. [O]verwrite, or" + " [A]bort(o/a)? ";
          DO: DO: A$ = INKEY$: LOOP UNTIL LEN(A$): A$ = UCASE$(A$)
          LOOP UNTIL INSTR("OA" + CHR$(27), A$)
          LOCATE , 1: PRINT SPACE$(78); : LOCATE , 1
          SELECT CASE A$
          CASE "A", CHR$(27): GERR% = -1: PRINT "Aborted by user!": GOTO DecodeExit
          END SELECT
        END IF
      END IF
      GERR% = 0: OPEN OutPath$ + OutFile$ FOR OUTPUT AS OutputHandle%
      IF GERR% THEN PRINT "Error while opening "; OutPath$ + OutFile$; "!": GOTO DecodeExit
      OutSpecOpened% = True
      IF ScriptType% = 0 THEN PRINT "Unfiltering ";  ELSE PRINT "Decoding ";
      PRINT OutPath$ + OutFile$; "... ";
      LookingForNextPage% = False
      CurrentPage% = 1
      DO UNTIL EOF(InputHandle%)
        IF GERR% THEN PRINT "Error #"; STR$(GERR%); " while processing" + " file!": GOTO DecodeExit
        M% = M% + 1: IF M% = 16 THEN GOSUB AbortCheck
        LineNum& = LineNum& + 1
        LINE INPUT #InputHandle%, A$: A$ = RTRIM$(A$)
        IF ScriptType% = 1 THEN A$ = LTRIM$(A$)
        IF LEFT$(A$, 4) = "'>>>" THEN
          GOSUB CheckLine
          IF UCASE$(LEFT$(A$, 10)) = "'>>> PAGE " THEN
            A$ = UCASE$(A$)
            IF LEFT$(A$, 15) = "'>>> PAGE 1 OF " AND INSTR(A$, "BEGINS" + " HERE") > 0 THEN
              PRINT "Premature end of script on line"; LineNum&
              FoundNewScript% = True: BadScript% = True: EXIT DO
            END IF
            IF GrabNum&(MID$(A$, 11), 1, 256, -1) <> CurrentPage% THEN PRINT "Page out of sync on line"; LineNum&: BadScript% = True: EXIT DO
            IF INSTR(A$, "BEGINS HERE") THEN
              IF LookingForNextPage% = False THEN PRINT "Page"; CurrentPage%; " was encountered more than once on line"; LineNum&: BadScript% = True: EXIT DO
              LookingForNextPage% = False
            ELSEIF INSTR(A$, "ENDS HERE") THEN
              IF LookingForNextPage% = True THEN PRINT "Page"; CurrentPage%; "was terminated prematurely on line"; LineNum&: BadScript% = True: EXIT DO
              LookingForNextPage% = True
              CurrentPage% = CurrentPage% + 1
              IF INSTR(A$, "LAST PAGE") THEN ScrDone% = True: EXIT DO
            ELSE
              PRINT "Bad page header on line"; LineNum&: BadScript% = True: EXIT DO
            END IF
          END IF
        ELSE
          IF LookingForNextPage% = False THEN
            IF ScriptType% = 0 THEN
              GOSUB ShrinkLine
            ELSE
              IF LEFT$(A$, 1) = "U" AND LEFT$(LTRIM$(MID$(A$, 2)), 1) = CHR$(34) THEN GOSUB DecodeLine
            END IF
          END IF
        END IF
      LOOP
      IF BadScript% = False THEN
        IF ScrDone% = False THEN PRINT "Premature end of script on" + " line"; LineNum&: BadScript% = True: GOTO DecodeDone
        GoodScripts% = GoodScripts% + 1
        IF ScriptType% = 0 THEN
          IF NumLines% > 0 THEN A$ = "": GOSUB ShrinkLine
          PRINT "Ok"
        ELSE
          IF FilesLength& = -1 THEN
            PRINT "Warning: File's length could not be located!"
          ELSEIF FilesLength& <> B& THEN
            PRINT "Warning: Decoded file's length is incorrect."
          ELSEIF FilesCRC% = -1 THEN
            PRINT "Warning: File's checksum could not be located!"
          ELSEIF FilesCRC% <> s% THEN
            PRINT "Warning: Decoded file's checksum is incorrect."
          ELSE
            PRINT "Ok"
          END IF
        END IF
      END IF
DecodeDone:
      CLOSE OutputHandle%
      IF GERR% THEN PRINT "Error while writing to output file!": GOTO DecodeExit
      IF BadScript% THEN KILL OutPath$ + OutFile$
      OutSpecOpened% = False
      PRINT : IF OutFile$ = OutName$ THEN EXIT DO
    END IF
FindNext:
  LOOP UNTIL EOF(InputHandle%)
'----------------------------------------------------------
DecodeExit:
  Q% = GERR%: CLOSE InputHandle%: CLOSE OutputHandle%
  IF Q% = 0 THEN PRINT LTRIM$(STR$(GoodScripts%)); " script(s) decoded" + " successfully."
  IF Q% <> 0 AND OutSpecOpened% THEN KILL OutPath$ + OutFile$
  Decode% = Q%
EXIT FUNCTION
'----------------------------------------------------------
ShrinkLine:
  FoundIt% = FASC(RIGHT$(A$, 1)) = 95
  IF FoundIt% THEN
    InQuote% = False
    FOR I% = 1 TO LEN(A$)
      IF MID$(A$, I%, 1) = CHR$(34) THEN InQuote% = NOT InQuote%
    NEXT
    'Don't combine lines that are part of binary scripts
    IF InQuote% THEN FoundIt% = False
  END IF
  IF FoundIt% OR NumLines% > 0 THEN
    IF NumLines% = 256 THEN
      PRINT "Too many line continuations!": BadScript% = True: GOTO DecodeDone
    END IF
    NumLines% = NumLines% + 1: Lines$(NumLines%) = A$
    IF FoundIt% = False THEN 'last line?
      A$ = ""
      FOR A% = 1 TO NumLines%
        B$ = Lines$(A%)
        'can we combine two quoted strings together?
        CombineQuote% = False
        IF RIGHT$(A$, 2) = "+_" AND LEN(A$) > 3 THEN
          IF RIGHT$(RTRIM$(LEFT$(A$, LEN(A$) - 2)), 1) = CHR$(34) THEN
            IF FASC(LTRIM$(B$)) = 34 THEN CombineQuote% = True
          END IF
        END IF
        IF CombineQuote% THEN
          A$ = RTRIM$(LEFT$(A$, LEN(A$) - 2))
          A$ = LEFT$(A$, LEN(A$) - 1) + MID$(LTRIM$(B$), 2)
        ELSE
          InQuote% = False
          'can we combine two remarks together?
          FOR I% = 1 TO LEN(A$)
            Q$ = MID$(A$, I%, 1)
            IF Q$ = CHR$(34) THEN
              InQuote% = NOT InQuote%
            ELSEIF InQuote% = False THEN
              IF Q$ = "'" OR UCASE$(MID$(A$, I%, 4)) = "REM " THEN
                IF LEFT$(LTRIM$(B$), 1) = "'" THEN B$ = MID$(B$, 2)
                EXIT FOR
              END IF
            END IF
          NEXT
          'eradicate trailing "_" character
          IF LEN(A$) THEN A$ = LEFT$(A$, LEN(A$) - 1)
          A$ = A$ + B$
        END IF
      NEXT
      PRINT #OutputHandle%, A$: NumLines% = 0
    END IF
  ELSE
    PRINT #OutputHandle%, A$
  END IF
  IF GERR% THEN PRINT "Error while writing to output file!": GOTO DecodeExit
RETURN

DecodeLine: '**MOD 86 Decoder**
  A$ = MID$(LTRIM$(MID$(A$, 2)), 2)
  IF RIGHT$(A$, 1) = CHR$(34) THEN A$ = LEFT$(A$, LEN(A$) - 1)
  FOR A% = 1 TO LEN(A$)
    C% = ASC(MID$(A$, A%, 1))
    IF ValidChar%(C%) = False THEN PRINT "Illegal character found on" + " line"; LineNum&: BadScript% = True: GOTO DecodeDone
    C% = C% - 37: IF C% < 0 THEN C% = 91 + C% * 32
    IF K% < 4 THEN
      IF C% > 80 THEN PRINT "Decode out of sync/illegal character found" + " on line"; LineNum&: BadScript% = True: GOTO DecodeDone
      K% = C% + 243
    ELSE
      T% = C% + (K% MOD 3) * 86: IF T% > 255 THEN PRINT "Illegal" + " character found on line"; LineNum&: BadScript% = True: GOTO DecodeDone
      PRINT #OutputHandle%, CHR$(T%);
      IF GERR% THEN PRINT "Error while writing to output file!": GOTO DecodeExit
      B& = B& + 1: K% = K% \ 3
    END IF
    s% = (s% + C%) AND 255
  NEXT
RETURN
'----------------------------------------------------------
CheckLine:
  Q% = INSTR(A$, "TLEN:")
  IF Q% THEN FilesLength& = GrabNum&(MID$(A$, Q% + 5), 1, 153600, -1)
  Q% = INSTR(A$, "TCHK:")
  IF Q% THEN FilesCRC% = GrabNum&(MID$(A$, Q% + 5), 0, 255, -1)
RETURN
'----------------------------------------------------------
AbortCheck: M% = 0: K$ = INKEY$
  IF K$ = CHR$(27) OR K$ = CHR$(0) + CHR$(0) THEN GERR% = -1: PRINT "Aborted by user!": GOTO DecodeExit
RETURN
END FUNCTION

FUNCTION Encode% (Op%, iSwitch%, cSwitch%, aSwitch%, tSwitch%, sSwitch%, pSwitch%, lSwitch%, oSwitch%, bSwitch%, InSpec$, OutSpec$)
  DIM OutputFile$(1 TO 256), Bucket%(1 TO 4), Lines$(64)
  GERR% = 0: Q$ = CHR$(34)
'----------------------------------------------------------
  SepPath InSpec$, OutDrive$, OutPath$, InName$
  SepPath OutSpec$, OutDrive$, OutPath$, OutName$
  IF LEN(OutName$) = 0 THEN
    OutName$ = InName$
    IF INSTR(OutName$, ".") THEN OutName$ = LEFT$(OutName$, INSTR(OutName$, ".") - 1)
  END IF
  IF INSTR(OutName$, ".") THEN
    OutExt$ = MID$(OutName$, INSTR(OutName$, "."))
    OutName$ = LEFT$(OutName$, INSTR(OutName$, ".") - 1)
  END IF
  IF LEN(OutExt$) = 0 THEN IF Op% THEN OutExt$ = ".PST" ELSE OutExt$ = ".PI"
'----------------------------------------------------------
  InputHandle% = FREEFILE
  IF Op% THEN
    OPEN InSpec$ FOR INPUT AS InputHandle% LEN = 8192
  ELSE
    OPEN InSpec$ FOR BINARY AS InputHandle%
  END IF
  InputFileSize& = LOF(InputHandle%)
  IF Op% = 0 AND InputFileSize& > (150 * 1024&) THEN
    PRINT "Can't encode files larger than 150k."
    GERR% = -1: GOTO EncodeExit
  ELSEIF InputFileSize& = 0 THEN
    PRINT "Input file is null.": GERR% = -2: GOTO EncodeExit
  END IF
'----------------------------------------------------------
  IF Op% THEN PRINT "Filtering ";  ELSE PRINT "Encoding ";
  PRINT InSpec$; " ("; LTRIM$(STR$((InputFileSize& + 1023) \ 1024)); "k)"
  PRINT
'----------------------------------------------------------
  OutputHandle% = FREEFILE: LinesInPage% = 0
'----------------------------------------------------------
  IF Op% = 0 THEN
    Work$ = "U" + Q$ + SPACE$(lSwitch% - 2): WorkPos% = 3
    CurrentSub% = 0: LinesInSub% = 0: FlagScaler% = 1
    GOSUB PrintDecodeHeader
    BytesLeft& = InputFileSize&: BufferSize% = 4096
    Buffer$ = SPACE$(BufferSize)
    DO
      IF GERR% THEN PRINT "- Error #"; STR$(GERR%); " while encoding" + " file!": GOTO EncodeExit
      IF BytesLeft& < BufferSize% THEN Buffer$ = SPACE$(BytesLeft&): BufferSize% = BytesLeft&
      GET InputHandle%, , Buffer$
      IF GERR% THEN PRINT "- Error while reading from input file!": GOTO EncodeExit
      GOSUB EncodeBlock
    LOOP WHILE BytesLeft&
    IF NumCodes% THEN GOSUB FlushCodeBuffer
    IF WorkPos% > 3 THEN Work$ = LEFT$(Work$, WorkPos% - 1): GOSUB PutSubLine
    IF LinesInSub% THEN L$ = "END SUB": GOSUB PutLine
    FOR A% = 2 TO CurrentSub%: L$ = "V" + HEX$(A%): GOSUB PutLine: NEXT
    GOSUB PrintDecodeTrailer
  ELSE
    BytesLeft& = InputFileSize&
    DO UNTIL EOF(InputHandle)
      IF GERR% THEN PRINT "- Error #"; STR$(GERR%); " while filtering" + " file!": GOTO EncodeExit
      LINE INPUT #InputHandle, A$: A$ = RTRIM$(UnTab$(A$, tSwitch%))
      IF GERR% THEN PRINT "- Error while reading from input file!": GOTO EncodeExit
      IF cSwitch% THEN A$ = LTRIM$(A$)
      BytesLeft& = BytesLeft& - LEN(A$) - 2
      IF LEN(A$) > 0 OR iSwitch% = False THEN
        ExpandLine A$, Lines$(), lSwitch%, NumLines%
        'Don't let split lines cross page boundries, because QB won't
        'put them back together.
        IF sSwitch% = False AND (NumLines% > 1) AND (LinesInPage% + 1 + NumLines%) > pSwitch% THEN
          PRINT #OutputHandle%, "'>>> Page"; STR$(NumOutputFiles%); " of "; InName$; " ends here. Continued on next page."
          LinesInPage% = LinesInPage% + 1: GOSUB CloseOutputFile
        END IF
        FOR A% = 1 TO NumLines%
          L$ = Lines$(A%)
          'Don't let blank lines proceed the first page header.
          IF LinesInPage% <> 0 OR LEN(RTRIM$(L$)) > 0 THEN
            'The padding option is for those unfortunates that post
            'source online in RBBS's grubby line oriented text editor...
            IF aSwitch% THEN IF LEN(L$) = 0 THEN L$ = " "
            GOSUB PutLine
          END IF
        NEXT
      END IF
    LOOP
  END IF
'----------------------------------------------------------
  L$ = "'>>> Page" + STR$(NumOutputFiles%) + " of " + InName$ + "ends" + " here. Last page."
  IF Op% = 0 THEN L$ = L$ + " TCHK:" + LTRIM$(STR$(CheckSum%))
  GOSUB PutLine: GOSUB CloseOutputFile: PRINT
  PRINT LTRIM$(STR$(TotalLines%)); " lines in"; STR$(NumOutputFiles%); " message(s) written."
'----------------------------------------------------------
EncodeExit:
  Q% = GERR%
  CLOSE InputHandle%: CLOSE OutputHandle%
  IF Q% <> 0 THEN FOR A% = 1 TO NumOutputFiles%: KILL OutputFile$(A%): NEXT
  Encode% = Q%
EXIT FUNCTION
'----------------------------------------------------------
EncodeBlock: '**MOD 86 Encoder**
  FOR I% = 1 TO BufferSize%
    Byte% = ASC(MID$(Buffer$, I%, 1)): BytesLeft& = BytesLeft& - 1
    CurrentFlag% = CurrentFlag% + (Byte% \ 86) * FlagScaler%
    FlagScaler% = FlagScaler% * 3: NumCodes% = NumCodes% + 1
    Bucket%(NumCodes%) = Byte% MOD 86
    IF NumCodes% = 4 THEN GOSUB FlushCodeBuffer
  NEXT
RETURN
'----------------------------------------------------------
FlushCodeBuffer:
  Q% = CurrentFlag%: GOSUB PutByte
  FOR J% = 1 TO NumCodes%: Q% = Bucket%(J%): GOSUB PutByte: NEXT
  NumCodes% = 0: CurrentFlag% = 0: FlagScaler% = 1
RETURN
'----------------------------------------------------------
PutByte:
  CheckSum% = (CheckSum% + Q%) AND 255
  IF Q% = 27 THEN
    MID$(Work$, WorkPos%) = "#"
  ELSEIF Q% = 59 THEN
    MID$(Work$, WorkPos%) = "$"
  ELSE
    MID$(Work$, WorkPos%) = CHR$(Q% + 37)
  END IF
  WorkPos% = WorkPos% + 1: IF WorkPos% > lSwitch% THEN GOSUB PutSubLine
RETURN
'----------------------------------------------------------
PutSubLine:
  IF LinesInSub% = 0 THEN
    CurrentSub% = CurrentSub% + 1
    IF CurrentSub% = 1 THEN
      L$ = "SUB V1:OPEN " + Q$ + "O" + Q$ + ",1," + Q$ + InName$ + Q$ + ",4^6:Z&=" + LTRIM$(STR$(LOF(1))) + ":?STRING$(50,177);"
    ELSE
      L$ = "SUB V" + HEX$(CurrentSub%)
    END IF
    GOSUB PutLine
  END IF
  L$ = Work$: GOSUB PutLine
  LinesInSub% = LinesInSub% + 1
  IF LinesInSub% = 200 THEN L$ = "END SUB": GOSUB PutLine:
LinesInSub% = 0
  WorkPos% = 3
RETURN
'----------------------------------------------------------
PutLine:
  IF LinesInPage% = 0 THEN GOSUB OpenNewOutputFile
  PRINT #OutputHandle%, L$
  IF GERR% THEN PRINT "- Error writing to output file!": GOTO EncodeExit
  LinesInPage% = LinesInPage% + 1
  IF sSwitch% = False THEN
    'make sure last page has some meat on it
    IF LinesInPage% = (pSwitch% - 1) OR (BytesLeft& < 256 AND LinesInPage% > (pSwitch% - 10)) THEN
      PRINT #OutputHandle%, "'>>> Page"; STR$(NumOutputFiles%); " of"; InName$; " ends here. Continued on next page."
      LinesInPage% = LinesInPage% + 1: GOSUB CloseOutputFile
    END IF
  END IF
  'Check the blower for contol+c and escape every few lines...
  IF (LinesInPage% AND 7) = 1 THEN
    A$ = INKEY$: IF A$ = CHR$(27) OR A$ = CHR$(0) + CHR$(0) THEN GERR% = -3: PRINT "- Aborted by user!": GOTO EncodeExit
  END IF
RETURN
'----------------------------------------------------------
OpenNewOutputFile:
  IF NumOutputFiles% = 256 THEN GERR% = -4: PRINT "Too many output" + " files!": GOTO EncodeExit
  NumOutputFiles% = NumOutputFiles% + 1
  IF sSwitch% = True THEN
    J$ = OutName$
  ELSE
    J$ = LTRIM$(STR$(NumOutputFiles%))
    J$ = LEFT$(OutName$, 8 - LEN(J$)) + J$
  END IF
  OutFile$ = OutDrive$ + OutPath$ + J$ + OutExt$: GERR% = 0
  OPEN OutFile$ FOR INPUT AS OutputHandle%: CLOSE OutputHandle%
  IF GERR% = 0 THEN
    IF oSwitch% = False THEN
      PRINT OutFile$; " already exists. [O]verwrite, overwrite [R]est," + " or [A]bort(o/r/a)? ";
      DO: DO: A$ = INKEY$: LOOP UNTIL LEN(A$): A$ = UCASE$(A$)
      LOOP UNTIL INSTR("ORA" + CHR$(27), A$)
      LOCATE , 1: PRINT SPACE$(78); : LOCATE , 1
      SELECT CASE A$
      CASE "A", CHR$(27): GERR% = -3: PRINT "Aborted by user!"
        NumOutputFiles% = NumOutputFiles% - 1: GOTO EncodeExit
      CASE "R": oSwitch% = True
      END SELECT
    END IF
  END IF
  PRINT "Now writing: "; OutFile$; " ";
  GERR% = 0: OPEN OutFile$ FOR OUTPUT AS OutputHandle% LEN = 4096
  OutputFile$(NumOutputFiles%) = OutFile$
  IF GERR% THEN
    PRINT "- Error opening output file!"
    NumOutputFiles% = NumOutputFiles% - 1: GOTO EncodeExit
  END IF
  LinesInPage% = 1
  IF NumOutputFiles% = 1 THEN
    FOR I% = 1 TO bSwitch%
      IF aSwitch% THEN PRINT #OutputHandle, " " ELSE PRINT #OutputHandle,
    NEXT
    LinesInPage% = LinesInPage% + bSwitch%
  END IF
  PRINT #OutputHandle%, "'>>> Page"; STR$(NumOutputFiles%); " of "; InName$; " begins here.";
  IF NumOutputFiles% > 1 THEN
    PRINT #OutputHandle%,
  ELSE
    IF Op% = 0 THEN
      'The first letter after "BIN" is  which algorithm was used
      'to encode the file. The second letter is the minimum decoding
      'algorithm required to extract the file. Both range from A-Z.
      PRINT #OutputHandle%, " TYPE:BINAA";
      'TLEN stands for "total length".
      PRINT #OutputHandle%, " TLEN:"; LTRIM$(STR$(InputFileSize&))
      'In the future, other information may be put onto this line,
      'such as the file's date and time. (Actually, any line
      'starting will "'>>>" will be scanned for information by
      'the Decode function.)
    ELSE
      PRINT #OutputHandle%, " TYPE:BAS"
    END IF
  END IF
  GERR% = 0
RETURN
'----------------------------------------------------------
CloseOutputFile:
  CLOSE OutputHandle%
  IF GERR% THEN PRINT "- Error while writing to output file!": GOTO EncodeExit
  PRINT : TotalLines% = TotalLines% + LinesInPage%: LinesInPage% = 0
RETURN
'----------------------------------------------------------
PrintDecodeHeader:
  L$ = "DEFINT A-Z:DIM SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.1"
  GOSUB PutLine
RETURN
'----------------------------------------------------------
PrintDecodeTrailer:
  L$ = "CLOSE:IF S=" + LTRIM$(STR$(CheckSum%))
  L$ = L$ + "AND B&=Z&THEN?" + Q$ + " :) Ok!" + Q$ + "ELSE?" + Q$ + "" + ":( Bad!"
  GOSUB PutLine
  L$ = "SUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:IF C<0THEN" + " C=91+C*32"
  GOSUB PutLine
  L$ = "IF K<4THEN K=C+243ELSE?#1,CHR$(C+(K MOD 3)*86);:K=K\3:B&=B&+1"
  GOSUB PutLine
  L$ = "S=(S+C)AND 255:NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUB"
  GOSUB PutLine
RETURN
END FUNCTION

'This self containted subroutine for splitting QB lines was made by
'Victor Yiu and a few other folks on the QUIK_BAS echo.
SUB ExpandLine (A$, Lines$(), LineLength%, NumLines%)
  NumLines% = 0
  'check to see if the line has already been split
  FOR I% = LEN(A$) TO 1 STEP -1
    SELECT CASE MID$(A$, I%, 1)
    CASE "_": NoSplit% = True
    CASE " "
    CASE ELSE: EXIT FOR
    END SELECT
  NEXT
  DO WHILE NoSplit% = False AND LEN(A$) > LineLength%
    'locate a place to split the line
    WrapPoint% = 0
    FOR I% = LineLength% TO LineLength% - 20 STEP -1
      SELECT CASE MID$(A$, I%, 1)
      CASE " ", ".", ",", ":", ";": WrapPoint% = I%: EXIT FOR
      END SELECT
    NEXT
    IF WrapPoint% = 0 THEN WrapPoint% = LineLength%
    'avoid wrapping on quote chars
    IF MID$(A$, WrapPoint% - 1, 1) = CHR$(34) THEN WrapPoint% = WrapPoint% - 1
    InQuote% = False: HasComment% = False
    'check to see if the line contains a remark
    FOR I% = 1 TO WrapPoint% - 1
      Q$ = MID$(A$, I%, 1)
      IF Q$ = CHR$(34) THEN
        InQuote% = NOT InQuote%
      ELSEIF InQuote% = False THEN
        IF Q$ = "'" OR UCASE$(MID$(A$, I%, 4)) = "REM " THEN
          HasComment% = True: EXIT FOR
        END IF
      END IF
    NEXT
    NumLines% = NumLines% + 1
    IF InQuote% THEN
      Lines$(NumLines%) = LEFT$(A$, WrapPoint% - 1) + CHR$(34) + "+_"
    ELSE
      Lines$(NumLines%) = LEFT$(A$, WrapPoint% - 1) + "_"
    END IF
    A$ = MID$(A$, WrapPoint%)
    IF HasComment% THEN
      A$ = "'" + A$
    ELSEIF InQuote% THEN
      A$ = CHR$(34) + A$
    END IF
  LOOP
  NumLines% = NumLines% + 1: Lines$(NumLines%) = A$
END SUB

FUNCTION FASC% (A$)
  IF LEN(A$) = 0 THEN FASC% = -1 ELSE FASC% = ASC(A$)
END FUNCTION

FUNCTION GrabNum& (A$, Lower&, Upper&, Default&)
  FOR I% = 1 TO LEN(A$)
    Q$ = MID$(A$, I%, 1): IF (Q$ < "0" OR Q$ > "9") THEN EXIT FOR
    J& = J& * 10& + ASC(Q$) - 48
    IF J& > Upper& THEN GrabNum& = Default&: EXIT FUNCTION
  NEXT
  GrabNum& = J&: IF LEN(A$) = 0 OR J& < Lower& OR J& > Upper& THEN GrabNum& = Default&
END FUNCTION

'This parsing sub does NOT mistake filenames like "F-14G.ZIP" as
'containing a switch. That's why it looks so big.
SUB ParseCmdLine (Cmd$, Params$(), Found%)
  Found% = 0: Sep$ = "-/": Temp$ = LTRIM$(RTRIM$(Cmd$)): InParam% = 0
  FOR p% = 1 TO LEN(Temp$)
    C$ = MID$(Temp$, p%, 1)
    IF InParam% = -1 THEN 'Inside of a switch?
      IF INSTR(Sep$, C$) THEN 'Found another switch?
        'Terminate current switch, then start parsing the next one.
        GOSUB MakeParam: MID$(Temp$, p%, 1) = LEFT$(Sep$, 1)
        ParamStart% = p%
      ELSEIF ASC(C$) = 32 OR ASC(C$) = 9 THEN
        GOSUB MakeParam: InParam% = 0 'Terminate current switch.
      END IF
    ELSEIF InParam% = -2 THEN 'Inside of a parameter?
      IF ASC(C$) = 32 OR ASC(C$) = 9 THEN 'Terminate parameter with
        GOSUB MakeParam: InParam% = 0     'space or TAB.
      END IF
    ELSE
      IF INSTR(Sep$, C$) THEN 'Found start of a switch?
        'Make sure all switches start with "-".
        MID$(Temp$, p%, 1) = LEFT$(Sep$, 1): InParam% = -1
        ParamStart% = p%
      ELSEIF ASC(C$) <> 32 AND ASC(C$) <> 9 THEN 'If char isn't a
        InParam% = -2: ParamStart% = p% 'space or TAB it's a parameter.
      END IF
    END IF
  NEXT
  IF InParam% THEN GOSUB MakeParam
  EXIT SUB
MakeParam:
  Found% = Found% + 1
  Params$(Found%) = MID$(Temp$, ParamStart%, p% - ParamStart%)
  IF Found% = UBOUND(Params$) THEN EXIT SUB
RETURN
END SUB

SUB SepPath (A$, Drive$, path$, tName$)
  FOR I% = LEN(A$) TO 1 STEP -1
    IF INSTR("\:", MID$(A$, I%, 1)) THEN EXIT FOR
  NEXT
  IF I% > 0 THEN
    path$ = UCASE$(MID$(A$, 1, I%)): tName$ = UCASE$(MID$(A$, I% + 1))
  ELSE
    path$ = "": tName$ = UCASE$(A$)
  END IF
  Temp% = INSTR(path$, ":"): Drive$ = ""
  IF Temp% THEN Drive$ = LEFT$(path$, Temp%): path$ = MID$(path$, Temp% + 1)
END SUB

FUNCTION UnTab$ (B$, TabStops%)
  A$ = B$: T% = INSTR(A$, CHR$(9))
  IF T% THEN
    DO: Temp% = (T% - 1) MOD TabStops%
    A$ = LEFT$(A$, T% - 1) + SPACE$(TabStops% - Temp%) + MID$(A$, T% + 1)
    T% = INSTR(T%, A$, CHR$(9)): LOOP WHILE T%
  END IF
  UnTab$ = A$
END FUNCTION '(last subroutine)

'